add lisp packages
This commit is contained in:
958
lisp/ace-window.el
Normal file
958
lisp/ace-window.el
Normal file
@@ -0,0 +1,958 @@
|
|||||||
|
;;; ace-window.el --- Quickly switch windows. -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
|
||||||
|
|
||||||
|
;; Author: Oleh Krehel <ohwoeowho@gmail.com>
|
||||||
|
;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
240
lisp/adaptive-wrap.el
Normal file
240
lisp/adaptive-wrap.el
Normal file
@@ -0,0 +1,240 @@
|
|||||||
|
;;; adaptive-wrap.el --- Smart line-wrapping with wrap-prefix
|
||||||
|
|
||||||
|
;; Copyright (C) 2011-2018 Free Software Foundation, Inc.
|
||||||
|
|
||||||
|
;; Author: Stephen Berman <stephen.berman@gmx.net>
|
||||||
|
;; Stefan Monnier <monnier@iro.umontreal.ca>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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 <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * adaptive-wrap.el (adaptive-wrap-fill-context-prefix): Ignore
|
||||||
|
;; paragraph-start
|
||||||
|
;;
|
||||||
|
;; (and rename 'en' to 'end'). Reported by Dmitry Safronov
|
||||||
|
;; <saf.dmitry@gmail.com>
|
||||||
|
;;
|
||||||
|
;; 2018-10-15 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * 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 <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * 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 <npostavs@users.sourceforge.net>
|
||||||
|
;;
|
||||||
|
;; 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 <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * adaptive-wrap.el (adaptive-wrap-mode): Move after font-lock
|
||||||
|
;; (bug#15155).
|
||||||
|
;;
|
||||||
|
;; 2013-07-31 Stephen Berman <stephen.berman@gmx.net>
|
||||||
|
;;
|
||||||
|
;; * 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 <stephen.berman@gmx.net>
|
||||||
|
;;
|
||||||
|
;; * adaptive-wrap.el: Require easymenu (bug#14974).
|
||||||
|
;;
|
||||||
|
;; 2013-07-19 Rüdiger Sonderfeld <ruediger@c-plusplus.de>
|
||||||
|
;;
|
||||||
|
;; * 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 <stephen.berman@gmx.net>
|
||||||
|
;;
|
||||||
|
;; Fix error during redisplay: (wrong-type-argument stringp nil)
|
||||||
|
;;
|
||||||
|
;; 2012-12-05 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * adaptive-wrap.el (adaptive-wrap-extra-indent): Fix buffer-localness.
|
||||||
|
;; Reported by Jonathan Kotta <jpkotta@gmail.com>.
|
||||||
|
;;
|
||||||
|
;; 2012-10-30 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; Clean up copyright notices.
|
||||||
|
;;
|
||||||
|
;; 2012-05-21 Jonathan Kotta <jpkotta@gmail.com>
|
||||||
|
;;
|
||||||
|
;; 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 <cyd@gnu.org>
|
||||||
|
;;
|
||||||
|
;; Rename adaptive-wrap-prefix to adaptive-wrap.
|
||||||
|
;;
|
||||||
|
;; The old name overflowed the column in list-packages.
|
||||||
|
;;
|
||||||
|
|
||||||
|
|
||||||
|
(provide 'adaptive-wrap)
|
||||||
|
;;; adaptive-wrap.el ends here
|
||||||
1353
lisp/amx.el
Normal file
1353
lisp/amx.el
Normal file
File diff suppressed because it is too large
Load Diff
852
lisp/anaconda-mode.el
Normal file
852
lisp/anaconda-mode.el
Normal file
@@ -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 <proofit404@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
2226
lisp/avy.el
Normal file
2226
lisp/avy.el
Normal file
File diff suppressed because it is too large
Load Diff
889
lisp/biblio-core.el
Normal file
889
lisp/biblio-core.el
Normal file
@@ -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 <clement.pitclaudel@live.com>
|
||||||
|
;; 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 <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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 "<up>") #'biblio--selection-previous)
|
||||||
|
(define-key map (kbd "C-p") #'biblio--selection-previous)
|
||||||
|
(define-key map (kbd "<down>") #'biblio--selection-next)
|
||||||
|
(define-key map (kbd "C-n") #'biblio--selection-next)
|
||||||
|
(define-key map (kbd "RET") #'biblio--selection-browse)
|
||||||
|
(define-key map (kbd "<C-return>") #'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
|
||||||
1586
lisp/bibtex-completion.el
Normal file
1586
lisp/bibtex-completion.el
Normal file
File diff suppressed because it is too large
Load Diff
456
lisp/bind-key.el
Normal file
456
lisp/bind-key.el
Normal file
@@ -0,0 +1,456 @@
|
|||||||
|
;;; bind-key.el --- A simple way to manage personal keybindings
|
||||||
|
|
||||||
|
;; Copyright (c) 2012-2017 John Wiegley
|
||||||
|
|
||||||
|
;; Author: John Wiegley <johnw@newartisans.com>
|
||||||
|
;; Maintainer: John Wiegley <johnw@newartisans.com>
|
||||||
|
;; 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* "<C-return>" '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)
|
||||||
|
"#<lambda>"))
|
||||||
|
((eq 'closure (car elem))
|
||||||
|
(if (and bind-key-describe-special-forms
|
||||||
|
(stringp (nth 3 elem)))
|
||||||
|
(nth 3 elem)
|
||||||
|
"#<closure>"))
|
||||||
|
((eq 'keymap (car elem))
|
||||||
|
"#<keymap>")
|
||||||
|
(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
|
||||||
|
"#<byte-compiled lambda>")))
|
||||||
|
|
||||||
|
(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
|
||||||
137
lisp/cl-libify.el
Normal file
137
lisp/cl-libify.el
Normal file
@@ -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 <steve@sanityinc.com>
|
||||||
|
;; 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 <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
155
lisp/company-anaconda.el
Normal file
155
lisp/company-anaconda.el
Normal file
@@ -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 <proofit404@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
117
lisp/company-ledger.el
Normal file
117
lisp/company-ledger.el
Normal file
@@ -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 <debanjum AT gmail DOT com>
|
||||||
|
;; 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
|
||||||
271
lisp/company-quickhelp.el
Normal file
271
lisp/company-quickhelp.el
Normal file
@@ -0,0 +1,271 @@
|
|||||||
|
;;; company-quickhelp.el --- Popup documentation for completion candidates
|
||||||
|
|
||||||
|
;; Copyright (C) 2016, Lars Andersen
|
||||||
|
|
||||||
|
;; Author: Lars Andersen <expez@expez.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
6841
lisp/counsel.el
Normal file
6841
lisp/counsel.el
Normal file
File diff suppressed because it is too large
Load Diff
1871
lisp/crdt.el
Normal file
1871
lisp/crdt.el
Normal file
File diff suppressed because it is too large
Load Diff
1925
lisp/ctable.el
Normal file
1925
lisp/ctable.el
Normal file
File diff suppressed because it is too large
Load Diff
1866
lisp/deft.el
Normal file
1866
lisp/deft.el
Normal file
File diff suppressed because it is too large
Load Diff
495
lisp/delight.el
Normal file
495
lisp/delight.el
Normal file
@@ -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 <psainty@orcon.net.nz>
|
||||||
|
;; Maintainer: Phil Sainty <psainty@orcon.net.nz>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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 <psainty@orcon.net.nz>
|
||||||
|
;;
|
||||||
|
;; Merge commit '5a0cd5ccb650d7bba1c1ea02cf67b71d7cfa6e9a' from delight
|
||||||
|
;;
|
||||||
|
;; 2019-07-23 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * 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 <psainty@orcon.net.nz>
|
||||||
|
;;
|
||||||
|
;; Use GNU ELPA version number formatting
|
||||||
|
;;
|
||||||
|
;; 2016-07-13 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||||
|
;;
|
||||||
|
;; * delight.el: Fix copyright
|
||||||
|
;;
|
||||||
|
;; 2016-07-14 Phil Sainty <psainty@orcon.net.nz>
|
||||||
|
;;
|
||||||
|
;; 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
|
||||||
3039
lisp/dialog.el
Normal file
3039
lisp/dialog.el
Normal file
File diff suppressed because it is too large
Load Diff
163
lisp/dim.el
Normal file
163
lisp/dim.el
Normal file
@@ -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 <alezost@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
|
;; <http://www.emacswiki.org/emacs/delight.el> package, as the code of
|
||||||
|
;; this file is heavily based on it.
|
||||||
|
|
||||||
|
;; For more verbose description, see README at
|
||||||
|
;; <https://github.com/alezost/dim.el>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
156
lisp/ess-R-data-view.el
Normal file
156
lisp/ess-R-data-view.el
Normal file
@@ -0,0 +1,156 @@
|
|||||||
|
;;; ess-R-data-view.el --- Data viewer for GNU R
|
||||||
|
|
||||||
|
;; Author: myuhe <yuhei.maeda_at_gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
624
lisp/f.el
Normal file
624
lisp/f.el
Normal file
@@ -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 <johan.rejeep@gmail.com>
|
||||||
|
;; Maintainer: Johan Andersson <johan.rejeep@gmail.com>
|
||||||
|
;; 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
|
||||||
141
lisp/flycheck-ledger.el
Normal file
141
lisp/flycheck-ledger.el
Normal file
@@ -0,0 +1,141 @@
|
|||||||
|
;;; flycheck-ledger.el --- Flycheck integration for ledger files -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2013-2014 Steve Purcell
|
||||||
|
|
||||||
|
;; Author: Steve Purcell <steve@sanityinc.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
154
lisp/flycheck-pos-tip.el
Normal file
154
lisp/flycheck-pos-tip.el
Normal file
@@ -0,0 +1,154 @@
|
|||||||
|
;;; flycheck-pos-tip.el --- Display Flycheck errors in GUI tooltips -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2015-2016 Sebastian Wiesner <swiesner@lunaryorn.com>
|
||||||
|
;; Copyright (C) 2014 Akiha Senda
|
||||||
|
|
||||||
|
;; Author: Akiha Senda <senda.akiha@gmail.com>
|
||||||
|
;; Sebastian Wiesner <swiesner@lunaryorn.com>
|
||||||
|
;; Maintainer: Sebastian Wiesner <swiesner@lunaryorn.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
280
lisp/focus.el
Normal file
280
lisp/focus.el
Normal file
@@ -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 <larstvei@ifi.uio.no>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
1015
lisp/git-commit.el
Normal file
1015
lisp/git-commit.el
Normal file
File diff suppressed because it is too large
Load Diff
432
lisp/git-messenger.el
Normal file
432
lisp/git-messenger.el
Normal file
@@ -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 <syohex@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
459
lisp/gnuplot-mode.el
Normal file
459
lisp/gnuplot-mode.el
Normal file
@@ -0,0 +1,459 @@
|
|||||||
|
;;; gnuplot-mode.el --- Major mode for editing gnuplot scripts
|
||||||
|
|
||||||
|
;; Copyright (C) 2010-2013 Mike McCourt
|
||||||
|
;;
|
||||||
|
;; Authors: Mike McCourt <mkmcc@astro.berkeley.edu>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
|
||||||
|
;;; 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
|
||||||
1010
lisp/highlight-indent-guides.el
Normal file
1010
lisp/highlight-indent-guides.el
Normal file
File diff suppressed because it is too large
Load Diff
310
lisp/ht.el
Normal file
310
lisp/ht.el
Normal file
@@ -0,0 +1,310 @@
|
|||||||
|
;;; ht.el --- The missing hash table library for Emacs -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2013 Wilfred Hughes
|
||||||
|
|
||||||
|
;; Author: Wilfred Hughes <me@wilfred.me.uk>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
1884
lisp/htmlize.el
Normal file
1884
lisp/htmlize.el
Normal file
File diff suppressed because it is too large
Load Diff
328
lisp/indent-guide.el
Normal file
328
lisp/indent-guide.el
Normal file
@@ -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
|
||||||
206
lisp/ivy-bibtex.el
Normal file
206
lisp/ivy-bibtex.el
Normal file
@@ -0,0 +1,206 @@
|
|||||||
|
;;; ivy-bibtex.el --- A bibliography manager based on Ivy
|
||||||
|
|
||||||
|
;; Author: Justin Burkett <justin@burkett.cc>
|
||||||
|
;; Maintainer: Titus von der Malsburg <malsburg@posteo.de>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
1731
lisp/langtool.el
Normal file
1731
lisp/langtool.el
Normal file
File diff suppressed because it is too large
Load Diff
150
lisp/lv.el
Normal file
150
lisp/lv.el
Normal file
@@ -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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
9622
lisp/markdown-mode.el
Normal file
9622
lisp/markdown-mode.el
Normal file
File diff suppressed because it is too large
Load Diff
190
lisp/memoize.el
Normal file
190
lisp/memoize.el
Normal file
@@ -0,0 +1,190 @@
|
|||||||
|
;;; memoize.el --- Memoization functions -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; This is free and unencumbered software released into the public domain.
|
||||||
|
|
||||||
|
;; Author: Christopher Wellons <mosquitopsu@gmail.com>
|
||||||
|
;; URL: https://github.com/skeeto/emacs-memoize
|
||||||
|
;; Package-Version: 20200103.2036
|
||||||
|
;; Package-Commit: 51b075935ca7070f62fae1d69fe0ff7d8fa56fdd
|
||||||
|
;; Version: 1.1
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; `memoize' accepts a symbol or a function. When given a symbol, the
|
||||||
|
;; symbol's function definition is memoized and installed overtop of
|
||||||
|
;; the original function definition. When given a function, it returns
|
||||||
|
;; a memoized version of that function.
|
||||||
|
|
||||||
|
;; (memoize 'my-expensive-function)
|
||||||
|
|
||||||
|
;; `defmemoize' defines a memoized function directly, behaving just
|
||||||
|
;; like `defun'.
|
||||||
|
|
||||||
|
;; (defmemoize my-expensive-function (n)
|
||||||
|
;; (if (zerop n)
|
||||||
|
;; 1
|
||||||
|
;; (* n (my-expensive-function (1- n)))))
|
||||||
|
|
||||||
|
;; Memoizing an interactive function will render that function
|
||||||
|
;; non-interactive. It would be easy to fix this problem when it comes
|
||||||
|
;; to non-byte-compiled functions, but recovering the interactive
|
||||||
|
;; definition from a byte-compiled function is more complex than I
|
||||||
|
;; care to deal with. Besides, interactive functions are always used
|
||||||
|
;; for their side effects anyway.
|
||||||
|
|
||||||
|
;; There's no way to memoize nil returns, but why would your expensive
|
||||||
|
;; functions do all that work just to return nil? :-)
|
||||||
|
|
||||||
|
;; Memoization takes up memory, which should be freed at some point.
|
||||||
|
;; Because of this, all memoization has a timeout from when the last
|
||||||
|
;; access was. The default timeout is set by
|
||||||
|
;; `memoize-default-timeout'. It can be overridden by using the
|
||||||
|
;; `memoize' function, but the `defmemoize' macro will always just use
|
||||||
|
;; the default timeout.
|
||||||
|
|
||||||
|
;; If you wait to byte-compile the function until *after* it is
|
||||||
|
;; memoized then the function and memoization wrapper both get
|
||||||
|
;; compiled at once, so there's no special reason to do them
|
||||||
|
;; separately. But there really isn't much advantage to compiling the
|
||||||
|
;; memoization wrapper anyway.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
|
||||||
|
(defvar memoize-default-timeout "2 hours"
|
||||||
|
"The amount of time after which to remove a memoization.
|
||||||
|
This represents the time after last use of the memoization after
|
||||||
|
which the value is expired. Setting this to nil means to never
|
||||||
|
expire, which will cause a memory leak, but may be acceptable for
|
||||||
|
very careful uses.")
|
||||||
|
|
||||||
|
(defun memoize (func &optional timeout)
|
||||||
|
"Memoize FUNC: a closure, lambda, or symbol.
|
||||||
|
|
||||||
|
If argument is a symbol then install the memoized function over
|
||||||
|
the original function. The TIMEOUT value, a timeout string as
|
||||||
|
used by `run-at-time' will determine when the value expires, and
|
||||||
|
will apply after the last access (unless another access
|
||||||
|
happens)."
|
||||||
|
(cl-typecase func
|
||||||
|
(symbol
|
||||||
|
(when (get func :memoize-original-function)
|
||||||
|
(user-error "%s is already memoized" func))
|
||||||
|
(put func :memoize-original-documentation (documentation func))
|
||||||
|
(put func 'function-documentation
|
||||||
|
(concat (documentation func) " (memoized)"))
|
||||||
|
(put func :memoize-original-function (symbol-function func))
|
||||||
|
(fset func (memoize--wrap (symbol-function func) timeout))
|
||||||
|
func)
|
||||||
|
(function (memoize--wrap func timeout))))
|
||||||
|
|
||||||
|
(defun memoize-restore (func)
|
||||||
|
"Restore the original, non-memoized definition of FUNC.
|
||||||
|
FUNC should be a symbol which has been memoized with `memoize'."
|
||||||
|
(unless (get func :memoize-original-function)
|
||||||
|
(user-error "%s is not memoized" func))
|
||||||
|
(fset func (get func :memoize-original-function))
|
||||||
|
(put func :memoize-original-function nil)
|
||||||
|
(put func 'function-documentation
|
||||||
|
(get func :memoize-original-documentation))
|
||||||
|
(put func :memoize-original-documentation nil))
|
||||||
|
|
||||||
|
(defun memoize--wrap (func timeout)
|
||||||
|
"Return the memoized version of FUNC.
|
||||||
|
TIMEOUT specifies how long the values last from last access. A
|
||||||
|
nil timeout will cause the values to never expire, which will
|
||||||
|
cause a memory leak as memoize is use, so use the nil value with
|
||||||
|
care."
|
||||||
|
(let ((table (make-hash-table :test 'equal))
|
||||||
|
(timeouts (make-hash-table :test 'equal)))
|
||||||
|
(lambda (&rest args)
|
||||||
|
(let ((value (gethash args table)))
|
||||||
|
(unwind-protect
|
||||||
|
(or value (puthash args (apply func args) table))
|
||||||
|
(let ((existing-timer (gethash args timeouts))
|
||||||
|
(timeout-to-use (or timeout memoize-default-timeout)))
|
||||||
|
(when existing-timer
|
||||||
|
(cancel-timer existing-timer))
|
||||||
|
(when timeout-to-use
|
||||||
|
(puthash args
|
||||||
|
(run-at-time timeout-to-use nil
|
||||||
|
(lambda ()
|
||||||
|
(remhash args table))) timeouts))))))))
|
||||||
|
|
||||||
|
(defmacro defmemoize (name arglist &rest body)
|
||||||
|
"Create a memoize'd function. NAME, ARGLIST, DOCSTRING and BODY
|
||||||
|
have the same meaning as in `defun'."
|
||||||
|
(declare (indent 2) (doc-string 3) (debug defun))
|
||||||
|
`(progn
|
||||||
|
(defun ,name ,arglist
|
||||||
|
,@body)
|
||||||
|
(memoize (quote ,name))))
|
||||||
|
|
||||||
|
(defun memoize-by-buffer-contents (func)
|
||||||
|
"Memoize the given function by buffer contents.
|
||||||
|
If argument is a symbol then install the memoized function over
|
||||||
|
the original function."
|
||||||
|
(cl-typecase func
|
||||||
|
(symbol
|
||||||
|
(put func 'function-documentation
|
||||||
|
(concat (documentation func) " (memoized by buffer contents)"))
|
||||||
|
(fset func (memoize-by-buffer-contents--wrap (symbol-function func)))
|
||||||
|
func)
|
||||||
|
(function (memoize-by-buffer-contents--wrap func))))
|
||||||
|
|
||||||
|
(defun memoize-by-buffer-contents--wrap (func)
|
||||||
|
"Return the memoization based on the buffer contents of FUNC.
|
||||||
|
|
||||||
|
This form of memoization will be based off the current buffer
|
||||||
|
contents. A different memoization is stored for all buffer
|
||||||
|
contents, although old contents and no-longer-existant buffers
|
||||||
|
will get garbage collected."
|
||||||
|
;; We need 3 tables here to properly garbage collect. First is the
|
||||||
|
;; table for the memoization itself, `memoization-table'. It holds a
|
||||||
|
;; cons of the content hash and the function arguments.
|
||||||
|
;;
|
||||||
|
;; Buffer contents change often, though, so we want these entries to
|
||||||
|
;; be automatically garbage collected when the buffer changes or the
|
||||||
|
;; buffer goes away. To keep the entries around, we need to tie the
|
||||||
|
;; content hash to the buffer, so that the content hash string
|
||||||
|
;; doesn't go away until the buffer does. We do that with the
|
||||||
|
;; `buffer-to-contents-table'.
|
||||||
|
;;
|
||||||
|
;; But even if the buffer content does change, we need to expire the
|
||||||
|
;; memoization entries for that particular buffer content. So we
|
||||||
|
;; have a `contents-to-memoization-table' that we use to tie the
|
||||||
|
;; content hash to the memoization conses used as keys in the
|
||||||
|
;; `memoization-table'.
|
||||||
|
;;
|
||||||
|
;; If a buffer's value changes, we make sure the next time we put a
|
||||||
|
;; new value at the `buffer-to-contents-table', which causes the
|
||||||
|
;; hash string to disappear. This causes the hash-string to
|
||||||
|
;; disappear from the `contents-to-memoization-table', which causes
|
||||||
|
;; the memoizations based on that content string to disappear from
|
||||||
|
;; the `memoization-table'.
|
||||||
|
(let ((memoization-table (make-hash-table :test 'equal :weakness 'key))
|
||||||
|
(buffer-to-contents-table (make-hash-table :weakness 'key))
|
||||||
|
(contents-to-memoization-table (make-hash-table :weakness 'key)))
|
||||||
|
(lambda (&rest args)
|
||||||
|
(let* ((bufhash (secure-hash 'md5 (buffer-string)))
|
||||||
|
(memokey (cons bufhash args))
|
||||||
|
(value (gethash memokey memoization-table)))
|
||||||
|
(or value
|
||||||
|
(progn
|
||||||
|
(puthash (current-buffer) bufhash buffer-to-contents-table)
|
||||||
|
(puthash bufhash memokey contents-to-memoization-table)
|
||||||
|
(puthash memokey (apply func args) memoization-table)))))))
|
||||||
|
|
||||||
|
(defmacro defmemoize-by-buffer-contents (name arglist &rest body)
|
||||||
|
"Create a memoize'd-by-buffer-contents function. NAME, ARGLIST,
|
||||||
|
DOCSTRING and BODY have the same meaning as in `defun'."
|
||||||
|
(declare (indent defun))
|
||||||
|
`(progn
|
||||||
|
(defun ,name ,arglist
|
||||||
|
,@body)
|
||||||
|
(memoize-by-buffer-contents (quote ,name))))
|
||||||
|
|
||||||
|
(provide 'memoize)
|
||||||
|
|
||||||
|
;;; memoize.el ends here
|
||||||
827
lisp/mu4e-maildirs-extension.el
Normal file
827
lisp/mu4e-maildirs-extension.el
Normal file
@@ -0,0 +1,827 @@
|
|||||||
|
;;; mu4e-maildirs-extension.el --- Show mu4e maildirs summary in mu4e-main-view
|
||||||
|
|
||||||
|
;; This file is not part of Emacs
|
||||||
|
|
||||||
|
;; Copyright (C) 2013--2017 Andreu Gil Pàmies
|
||||||
|
|
||||||
|
;; Filename: mu4e-maildirs-extension.el
|
||||||
|
;; Version: 0.1
|
||||||
|
;; Package-Version: 20200508.712
|
||||||
|
;; Package-Commit: 4d2ece2226fa69a0e0bb23517a418145b92bd573
|
||||||
|
;; Author: Andreu Gil Pàmies <agpchil@gmail.com>
|
||||||
|
;; Created: 22-07-2013
|
||||||
|
;; Description: Show mu4e maildirs summary in mu4e-main-view with unread and
|
||||||
|
;; total mails for each maildir
|
||||||
|
;; URL: http://github.com/agpchil/mu4e-maildirs-extension
|
||||||
|
;; Package-Requires: ((dash "0.0.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 of the License, 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Usage:
|
||||||
|
;; (require 'mu4e-maildirs-extension)
|
||||||
|
;; (mu4e-maildirs-extension)
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
(require 'mu4e)
|
||||||
|
(require 'dash)
|
||||||
|
|
||||||
|
(defgroup mu4e-maildirs-extension nil
|
||||||
|
"Show mu4e maildirs summary in mu4e-main-view with unread and
|
||||||
|
total mails for each maildir."
|
||||||
|
:link '(url-link "https://github.com/agpchil/mu4e-maildirs-extension")
|
||||||
|
:prefix "mu4e-maildirs-extension-"
|
||||||
|
:group 'external)
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-action-key "u"
|
||||||
|
"Key shortcut to update index and cache."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(key-sequence))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-toggle-maildir-key (kbd "SPC")
|
||||||
|
"Key shortcut to expand/collapse maildir at point."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(key-sequence))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-action-text "\t* [u]pdate index & cache\n"
|
||||||
|
"Action text to display for updating the index and cache.
|
||||||
|
If set to 'Don't Display (nil)' it won't be displayed."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(choice string (const :tag "Don't Display" nil)))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-count-command-format
|
||||||
|
(concat mu4e-mu-binary " find %s --fields 'i' | wc -l")
|
||||||
|
"The command to count a maildir. [Most people won't need to edit this]."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-custom-list nil
|
||||||
|
"List of folders to show.
|
||||||
|
If set to nil all folders are shown.
|
||||||
|
|
||||||
|
Example:
|
||||||
|
'(\"/account1/INBOX\"
|
||||||
|
\"/account2/INBOX\")"
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(repeat string))
|
||||||
|
;; :type '(sexp))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-ignored-regex
|
||||||
|
nil
|
||||||
|
"Optional regular expression that is used for filtering list of
|
||||||
|
maildirs. It's a dynamic alternative to
|
||||||
|
mu4e-maildirs-extension-custom-list - new maildirs will
|
||||||
|
automatically appear in the list unless they are explicitly
|
||||||
|
ignored."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(choice string (const :tag "Show all maildirs" nil)))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-use-bookmarks
|
||||||
|
nil
|
||||||
|
"If non-nil, show the bookmarks count in the mu4e main view."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type 'boolean
|
||||||
|
:risky t)
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-use-maildirs
|
||||||
|
t
|
||||||
|
"If non-nil, show the maildir summary in the mu4e main view."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-insert-before-str "\n Misc"
|
||||||
|
"The place where the maildirs section should be inserted."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(choice (const :tag "Basics" "\n Basics")
|
||||||
|
(const :tag "Bookmarks" "\n Bookmarks")
|
||||||
|
(const :tag "Misc" "\n Misc")
|
||||||
|
(const :tag "End of file" "\n")))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-bookmark-format " (%u/%t)"
|
||||||
|
"The bookmark stats format.
|
||||||
|
|
||||||
|
Available formatters:
|
||||||
|
|
||||||
|
%u is the unread count
|
||||||
|
%t is the total count"
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-bookmark-format-spec
|
||||||
|
'(lambda(m)
|
||||||
|
(list (cons ?u (or (plist-get m :unread) ""))
|
||||||
|
(cons ?t (or (plist-get m :total) ""))))
|
||||||
|
"A function to build the bookmark format spec."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(function))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-bookmark-hl-regex
|
||||||
|
mu4e-maildirs-extension-bookmark-format
|
||||||
|
"Regex to highlight when `mu4e-maildirs-extension-bookmark-hl-pred' matches."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-bookmark-hl-pred
|
||||||
|
'(lambda(m)
|
||||||
|
(> (or (plist-get m :unread) 0) 0))
|
||||||
|
"Predicate function used to highlight."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(function))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-format "\t%i%p %n (%u/%t)"
|
||||||
|
"The maildir format.
|
||||||
|
|
||||||
|
Available formatters:
|
||||||
|
|
||||||
|
%i is the folder indentation
|
||||||
|
%p is the maildir prefix
|
||||||
|
%l is the folder level
|
||||||
|
%e is the expand flag
|
||||||
|
%P is the maildir path
|
||||||
|
%n is the maildir name
|
||||||
|
%u is the unread count
|
||||||
|
%t is the total count"
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-format-spec
|
||||||
|
'(lambda(m)
|
||||||
|
(list (cons ?i (plist-get m :indent))
|
||||||
|
(cons ?p (plist-get m :prefix))
|
||||||
|
(cons ?l (plist-get m :level))
|
||||||
|
(cons ?e (plist-get m :expand))
|
||||||
|
(cons ?P (plist-get m :path))
|
||||||
|
(cons ?n (plist-get m :name))
|
||||||
|
(cons ?u (or (plist-get m :unread) ""))
|
||||||
|
(cons ?t (or (plist-get m :total) ""))))
|
||||||
|
"A function to build the maildir format spec."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(function))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-hl-regex
|
||||||
|
mu4e-maildirs-extension-maildir-format
|
||||||
|
"Regex to highlight when `mu4e-maildirs-extension-maildir-hl-pred' matches."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-hl-pred
|
||||||
|
'(lambda(m)
|
||||||
|
(> (or (plist-get m :unread) 0) 0))
|
||||||
|
"Predicate function used to highlight."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(function))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-before-insert-maildir-hook
|
||||||
|
'(mu4e-maildirs-extension-insert-newline-when-root-maildir)
|
||||||
|
"Hook called before inserting a maildir."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type 'hook)
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-after-insert-maildir-hook
|
||||||
|
'(mu4e-maildirs-extension-insert-newline-when-unread)
|
||||||
|
"Hook called after inserting a maildir."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type 'hook)
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-propertize-bm-func
|
||||||
|
#'mu4e-maildirs-extension-propertize-bm-handler
|
||||||
|
"The function to format the bookmark info.
|
||||||
|
Default dispays as ' (unread/total)'."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(function))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-propertize-func
|
||||||
|
#'mu4e-maildirs-extension-propertize-handler
|
||||||
|
"The function to format the maildir info.
|
||||||
|
Default dispays as '| maildir_name (unread/total)'."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(function))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-indent 2
|
||||||
|
"Maildir indentation."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(integer))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-indent-char " "
|
||||||
|
"The char used for indentation."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(integer))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-default-collapse-level nil
|
||||||
|
"The default level to collapse maildirs.
|
||||||
|
Set `nil' to disable."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(choice integer nil))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-collapsed-prefix "+"
|
||||||
|
"The prefix for collapsed maildir."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-expanded-prefix "-"
|
||||||
|
"The prefix for expanded maildir."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-maildir-default-prefix "|"
|
||||||
|
"The prefix for default maildir."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-fake-maildir-separator nil
|
||||||
|
"The separator to fake a hierarchy using directory names.
|
||||||
|
For example:
|
||||||
|
/Archive
|
||||||
|
/Archive.foo
|
||||||
|
/Archive.foo.bar
|
||||||
|
/Archive.baz
|
||||||
|
|
||||||
|
Offlineimap does this when setting `sep = .'."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-updating-string "\n\t* Updating...\n"
|
||||||
|
"The string to show while updating in background."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(string))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-title " Maildirs\n"
|
||||||
|
"The title for the maildirs extension section.
|
||||||
|
If set to `nil' it won't be displayed."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(choice string (const :tag "Don't Display" nil)))
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-hide-empty-maildirs nil
|
||||||
|
"Non-nil indicates that maildirs with no new message are hidden."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
(defface mu4e-maildirs-extension-maildir-face
|
||||||
|
'((t :inherit mu4e-header-face))
|
||||||
|
"Face for a normal maildir."
|
||||||
|
:group 'mu4e-maildirs-extension)
|
||||||
|
|
||||||
|
(defface mu4e-maildirs-extension-maildir-hl-face
|
||||||
|
'((t :inherit mu4e-unread-face))
|
||||||
|
"Face for a highlighted maildir."
|
||||||
|
:group 'mu4e-maildirs-extension)
|
||||||
|
|
||||||
|
(defcustom mu4e-maildirs-extension-parallel-processes 6
|
||||||
|
"Max parallel processes."
|
||||||
|
:group 'mu4e-maildirs-extension
|
||||||
|
:type '(integer))
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-mu-14 (> (string-to-number mu4e-mu-version) 1.3))
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-running-processes 0)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-queue nil)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-start-point nil)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-end-point nil)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-maildirs nil)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-bookmarks nil)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-buffer-name
|
||||||
|
;; mu4e~main-buffer-name used to be private API, but is now public. We
|
||||||
|
;; maintain backward-compatibility with older versions.
|
||||||
|
(if (boundp 'mu4e~main-buffer-name)
|
||||||
|
mu4e~main-buffer-name
|
||||||
|
mu4e-main-buffer-name))
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-index-updated-func
|
||||||
|
'mu4e-maildirs-extension-index-updated-handler)
|
||||||
|
|
||||||
|
(defvar mu4e-maildirs-extension-main-view-func
|
||||||
|
'mu4e-maildirs-extension-main-view-handler)
|
||||||
|
|
||||||
|
(define-obsolete-variable-alias
|
||||||
|
'mu4e-maildirs-extension-submaildir-indent
|
||||||
|
'mu4e-maildirs-extension-maildir-indent
|
||||||
|
"0.9")
|
||||||
|
|
||||||
|
(define-obsolete-variable-alias
|
||||||
|
'mu4e-maildirs-extension-maildir-separator
|
||||||
|
'mu4e-maildirs-extension-maildir-collapsed-prefix
|
||||||
|
"0.9")
|
||||||
|
|
||||||
|
(define-obsolete-variable-alias
|
||||||
|
'mu4e-maildirs-extension-submaildir-separator
|
||||||
|
'mu4e-maildirs-extension-maildir-default-prefix
|
||||||
|
"0.9")
|
||||||
|
|
||||||
|
(define-obsolete-variable-alias
|
||||||
|
'mu4e-maildirs-extension-maildir-unread-face
|
||||||
|
'mu4e-maildirs-extension-maildir-hl-face
|
||||||
|
"0.9")
|
||||||
|
|
||||||
|
(define-obsolete-variable-alias
|
||||||
|
'mu4e-maildirs-extension-cached-maildirs-data
|
||||||
|
'mu4e-maildirs-extension-maildirs
|
||||||
|
"0.9")
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-index-updated-handler ()
|
||||||
|
"Handler for `mu4e-index-updated-hook'."
|
||||||
|
(let ((arg (if (get-buffer-window mu4e-maildirs-extension-buffer-name)
|
||||||
|
'(16)
|
||||||
|
'(4))))
|
||||||
|
(mu4e-maildirs-extension-force-update arg)))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-main-view-handler ()
|
||||||
|
"Handler for `mu4e-main-view-mode-hook'."
|
||||||
|
(setq mu4e-maildirs-extension-start-point nil)
|
||||||
|
(mu4e-maildirs-extension-update)
|
||||||
|
(mu4e-maildirs-extension-unqueue-maybe))
|
||||||
|
|
||||||
|
(defmacro mu4e-maildirs-extension-with-buffer (&rest body)
|
||||||
|
"Switch to `mu4e-maildirs-extension' buffer and yield BODY."
|
||||||
|
(declare (indent defun))
|
||||||
|
`(let* ((buffer (get-buffer mu4e-maildirs-extension-buffer-name))
|
||||||
|
(buffer-window (car (get-buffer-window-list buffer)))
|
||||||
|
(old-pos nil)
|
||||||
|
(inhibit-read-only t))
|
||||||
|
(when buffer
|
||||||
|
(cond (buffer-window
|
||||||
|
(with-selected-window buffer-window
|
||||||
|
(setq old-pos (point))
|
||||||
|
(save-excursion
|
||||||
|
,@body)
|
||||||
|
(unless (> old-pos (point-max))
|
||||||
|
(goto-char old-pos))))
|
||||||
|
(t
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(setq old-pos (point))
|
||||||
|
(save-excursion
|
||||||
|
,@body)
|
||||||
|
(unless (> old-pos (point-max))
|
||||||
|
(goto-char old-pos))))))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-unqueue-maybe ()
|
||||||
|
(when (< mu4e-maildirs-extension-running-processes
|
||||||
|
mu4e-maildirs-extension-parallel-processes)
|
||||||
|
(let ((proc-func (pop mu4e-maildirs-extension-queue)))
|
||||||
|
(cond (proc-func
|
||||||
|
(funcall proc-func)
|
||||||
|
(setq mu4e-maildirs-extension-running-processes
|
||||||
|
(1+ mu4e-maildirs-extension-running-processes)))
|
||||||
|
(t
|
||||||
|
(mu4e-maildirs-extension-update))))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-bookmark-command (query)
|
||||||
|
"Quote the mu bookmark command with arguments in QUERY quoted."
|
||||||
|
(format mu4e-maildirs-extension-count-command-format
|
||||||
|
(mapconcat #'append
|
||||||
|
(mapcar 'shell-quote-argument (split-string query " "))
|
||||||
|
" ")))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-maildir-command (path flags)
|
||||||
|
"Quote the mu maildir command with PATH and FLAGS arguments quoted."
|
||||||
|
(let ((query (format "%s %s"
|
||||||
|
(shell-quote-argument (concat "maildir:" (shell-quote-argument path)))
|
||||||
|
(shell-quote-argument flags))))
|
||||||
|
(format mu4e-maildirs-extension-count-command-format query)))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-fetch (cmd &optional callback)
|
||||||
|
"Execute the mu CMD in a shell process and fetch the result.
|
||||||
|
Optional call the function CALLBACK on finish."
|
||||||
|
(let* ((finish-func `(lambda(proc event)
|
||||||
|
(when (and (memq (process-status proc) '(exit))
|
||||||
|
(buffer-live-p (process-buffer proc))
|
||||||
|
,callback)
|
||||||
|
(let ((buffer (process-buffer proc))
|
||||||
|
(result nil))
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(setq result
|
||||||
|
(cond ((= 0 (process-exit-status proc))
|
||||||
|
(string-to-number
|
||||||
|
(replace-regexp-in-string "![0-9]"
|
||||||
|
""
|
||||||
|
(buffer-string))))
|
||||||
|
(t 0))))
|
||||||
|
(funcall ,callback result)
|
||||||
|
(kill-buffer buffer)
|
||||||
|
(setq mu4e-maildirs-extension-running-processes
|
||||||
|
(1- mu4e-maildirs-extension-running-processes))
|
||||||
|
(mu4e-maildirs-extension-unqueue-maybe)))))
|
||||||
|
(proc `(lambda()
|
||||||
|
(let ((proc (start-process-shell-command "mu4e-maildirs-extension"
|
||||||
|
(make-temp-name "mu4e-maildirs-extension")
|
||||||
|
,cmd)))
|
||||||
|
(set-process-sentinel proc ,finish-func)))))
|
||||||
|
|
||||||
|
(add-to-list 'mu4e-maildirs-extension-queue proc t)))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-parse (path)
|
||||||
|
"Get the maildir parents of maildir PATH name.
|
||||||
|
Given PATH \"/foo/bar/alpha\" will return '(\"/foo\" \"/bar\")."
|
||||||
|
(let ((name (replace-regexp-in-string "^/" "" path))
|
||||||
|
(parents nil)
|
||||||
|
(fake-sep mu4e-maildirs-extension-fake-maildir-separator)
|
||||||
|
(all-parents nil))
|
||||||
|
(setq name (replace-regexp-in-string "\\/\\*$" "" name))
|
||||||
|
(setq parents (split-string name "/" t))
|
||||||
|
(cond (mu4e-maildirs-extension-fake-maildir-separator
|
||||||
|
(mapc #'(lambda(s)
|
||||||
|
(setq all-parents (append all-parents (split-string s fake-sep t))))
|
||||||
|
parents))
|
||||||
|
(t (setq all-parents parents)))
|
||||||
|
all-parents))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-get-relevant-maildirs ()
|
||||||
|
"Get a list of maildirs set (or filtered) according to
|
||||||
|
configuration values."
|
||||||
|
(or mu4e-maildirs-extension-custom-list
|
||||||
|
(let ((list (mu4e-get-maildirs)))
|
||||||
|
(if mu4e-maildirs-extension-ignored-regex
|
||||||
|
(--remove (string-match mu4e-maildirs-extension-ignored-regex it) list)
|
||||||
|
list))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-paths ()
|
||||||
|
"Get maildirs paths."
|
||||||
|
(let ((paths (mu4e-maildirs-extension-get-relevant-maildirs))
|
||||||
|
(paths-to-show nil))
|
||||||
|
|
||||||
|
(mapc #'(lambda (name)
|
||||||
|
(let ((parents (butlast (mu4e-maildirs-extension-parse name)))
|
||||||
|
(path nil))
|
||||||
|
(mapc #'(lambda (parent-name)
|
||||||
|
(setq path (concat path "/" parent-name))
|
||||||
|
(unless (member path paths-to-show)
|
||||||
|
(add-to-list 'paths-to-show (format "%s/*" path) t)))
|
||||||
|
parents))
|
||||||
|
|
||||||
|
(add-to-list 'paths-to-show name t))
|
||||||
|
paths)
|
||||||
|
paths-to-show))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-update-maildir-prefix (m)
|
||||||
|
"Get the prefix of maildir M."
|
||||||
|
(let* ((l mu4e-maildirs-extension-maildirs)
|
||||||
|
(children (mu4e-maildirs-extension-children m l))
|
||||||
|
(prefix nil))
|
||||||
|
(setq prefix (cond ((and children (plist-get m :expand))
|
||||||
|
mu4e-maildirs-extension-maildir-expanded-prefix)
|
||||||
|
((and children (not (plist-get m :expand)))
|
||||||
|
mu4e-maildirs-extension-maildir-collapsed-prefix)
|
||||||
|
(t mu4e-maildirs-extension-maildir-default-prefix)))
|
||||||
|
(setq m (plist-put m :prefix prefix))
|
||||||
|
prefix))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-propertize-handler (m)
|
||||||
|
"Propertize the maildir text using M plist."
|
||||||
|
(let* ((fmt mu4e-maildirs-extension-maildir-format)
|
||||||
|
(hl-regex mu4e-maildirs-extension-maildir-hl-regex)
|
||||||
|
(hl-p (funcall mu4e-maildirs-extension-maildir-hl-pred m)))
|
||||||
|
(setq fmt (propertize fmt 'face 'mu4e-maildirs-extension-maildir-face))
|
||||||
|
(when hl-p
|
||||||
|
(setq fmt (replace-regexp-in-string hl-regex
|
||||||
|
(propertize hl-regex
|
||||||
|
'face
|
||||||
|
'mu4e-maildirs-extension-maildir-hl-face)
|
||||||
|
fmt)))
|
||||||
|
(format-spec fmt (funcall mu4e-maildirs-extension-maildir-format-spec m))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-load-bookmarks ()
|
||||||
|
"Fetch data or load from cache."
|
||||||
|
(unless mu4e-maildirs-extension-bookmarks
|
||||||
|
(mapc (lambda(it)
|
||||||
|
(let ((query (if mu4e-maildirs-extension-mu-14 (eval (plist-get it :query))
|
||||||
|
(eval (mu4e-bookmark-query it))))
|
||||||
|
(bm (list :data it)))
|
||||||
|
(when (stringp query)
|
||||||
|
(add-to-list 'mu4e-maildirs-extension-bookmarks bm t)
|
||||||
|
(mu4e-maildirs-extension-bm-count bm
|
||||||
|
:unread
|
||||||
|
(concat "(" query ") AND flag:unread"))
|
||||||
|
(mu4e-maildirs-extension-bm-count bm :total query))))
|
||||||
|
(mu4e-bookmarks)))
|
||||||
|
mu4e-maildirs-extension-bookmarks)
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-load-maildirs ()
|
||||||
|
"Fetch data or load from cache."
|
||||||
|
(unless mu4e-maildirs-extension-maildirs
|
||||||
|
(let ((paths (mu4e-maildirs-extension-paths)))
|
||||||
|
(setq mu4e-maildirs-extension-maildirs
|
||||||
|
(mapcar #'mu4e-maildirs-extension-new-maildir paths))))
|
||||||
|
(mapc #'(lambda (it)
|
||||||
|
(mu4e-maildirs-extension-count-unread it)
|
||||||
|
(mu4e-maildirs-extension-count-total it)
|
||||||
|
(mu4e-maildirs-extension-update-maildir-prefix it))
|
||||||
|
mu4e-maildirs-extension-maildirs)
|
||||||
|
mu4e-maildirs-extension-maildirs)
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-action-str (str &optional func-or-shortcut)
|
||||||
|
"Custom action without using [.] in STR.
|
||||||
|
If FUNC-OR-SHORTCUT is non-nil and if it is a function, call it
|
||||||
|
when STR is clicked (using RET or mouse-2); if FUNC-OR-SHORTCUT is
|
||||||
|
a string, execute the corresponding keyboard action when it is
|
||||||
|
clicked."
|
||||||
|
(let ((newstr str)
|
||||||
|
(map (make-sparse-keymap))
|
||||||
|
(func (if (functionp func-or-shortcut)
|
||||||
|
func-or-shortcut
|
||||||
|
(if (stringp func-or-shortcut)
|
||||||
|
(lexical-let ((macro func-or-shortcut))
|
||||||
|
(lambda()(interactive)
|
||||||
|
(execute-kbd-macro macro)))))))
|
||||||
|
(define-key map [mouse-2] func)
|
||||||
|
(define-key map (kbd "RET") func)
|
||||||
|
(put-text-property 0 (length newstr) 'keymap map newstr)
|
||||||
|
(put-text-property (string-match "[^\n\t\s-].+$" newstr)
|
||||||
|
(- (length newstr) 1) 'mouse-face 'highlight newstr)
|
||||||
|
newstr))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-run-when-unread (m func args)
|
||||||
|
"Call FUNC passing ARGS to it if M contains unread messages."
|
||||||
|
(when (or (not mu4e-maildirs-extension-hide-empty-maildirs)
|
||||||
|
(> (or (plist-get m :unread) 0) 0))
|
||||||
|
(funcall func args)))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-insert-newline-when-root-maildir (m)
|
||||||
|
"Insert a newline when M is a root maildir."
|
||||||
|
(when (equal (plist-get m :level) 0)
|
||||||
|
(insert "\n")))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-insert-newline (m)
|
||||||
|
"Insert a newline."
|
||||||
|
(insert "\n"))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-insert-newline-when-unread (m)
|
||||||
|
"Insert a newline if M contains unread messages."
|
||||||
|
(mu4e-maildirs-extension-run-when-unread m #'mu4e-maildirs-extension-insert-newline m))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-count (m key flags)
|
||||||
|
"Fetch count results using mu FLAGS and store result in M plist with KEY"
|
||||||
|
(let* ((path (plist-get m :path))
|
||||||
|
(cmd (mu4e-maildirs-extension-maildir-command path flags))
|
||||||
|
(count (plist-get m key))
|
||||||
|
(callback `(lambda(result)
|
||||||
|
(let ((m (--first (equal (plist-get it :path) ,path)
|
||||||
|
mu4e-maildirs-extension-maildirs)))
|
||||||
|
(setq m (plist-put m ,key result))))))
|
||||||
|
(unless count
|
||||||
|
(mu4e-maildirs-extension-fetch cmd callback))
|
||||||
|
(when (numberp count)
|
||||||
|
(number-to-string count))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-count-total (m)
|
||||||
|
"Fetch total count of M."
|
||||||
|
(or (mu4e-maildirs-extension-count m :total "") ""))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-count-unread (m)
|
||||||
|
"Fetch unread count of M."
|
||||||
|
(or (mu4e-maildirs-extension-count m :unread "flag:unread") ""))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-propertize-bm-handler (bm)
|
||||||
|
"Propertize the bookmark text using BM plist."
|
||||||
|
(let* ((fmt mu4e-maildirs-extension-bookmark-format)
|
||||||
|
(hl-regex mu4e-maildirs-extension-bookmark-hl-regex)
|
||||||
|
(hl-p (funcall mu4e-maildirs-extension-bookmark-hl-pred bm)))
|
||||||
|
(setq fmt (propertize fmt 'face 'mu4e-maildirs-extension-maildir-face))
|
||||||
|
(when hl-p
|
||||||
|
(setq fmt (replace-regexp-in-string hl-regex
|
||||||
|
(propertize hl-regex
|
||||||
|
'face
|
||||||
|
'mu4e-maildirs-extension-maildir-hl-face)
|
||||||
|
fmt)))
|
||||||
|
(format-spec fmt (funcall mu4e-maildirs-extension-maildir-format-spec bm))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-bm-update (bm-point)
|
||||||
|
"Update bookmark BM entry at MARKER in mu4e main view."
|
||||||
|
(when (cdr bm-point)
|
||||||
|
(goto-char (cdr bm-point))
|
||||||
|
(delete-region (point) (point-at-eol))
|
||||||
|
(insert (funcall mu4e-maildirs-extension-propertize-bm-func (car bm-point)))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-insert-maildir (m)
|
||||||
|
"Insert maildir entry into mu4e main view."
|
||||||
|
(insert (mu4e-maildirs-extension-action-str
|
||||||
|
(funcall mu4e-maildirs-extension-propertize-func m)
|
||||||
|
`(lambda (prefix)
|
||||||
|
(interactive "P")
|
||||||
|
(let ((maildir ,(plist-get m :path)))
|
||||||
|
(if prefix
|
||||||
|
(mu4e~headers-search-execute
|
||||||
|
(format "%s AND flag:unread"
|
||||||
|
(shell-quote-argument (concat "maildir:" maildir)))
|
||||||
|
nil)
|
||||||
|
(mu4e~headers-jump-to-maildir maildir)))))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-new-maildir (path)
|
||||||
|
"Build new maildir plist from maildir PATH."
|
||||||
|
(let* ((m nil)
|
||||||
|
(current-maildirs (mu4e-maildirs-extension-parse path))
|
||||||
|
(level (1- (length current-maildirs))))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:name (car (last current-maildirs))))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:level
|
||||||
|
level))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:expand (or (not mu4e-maildirs-extension-default-collapse-level)
|
||||||
|
(< level mu4e-maildirs-extension-default-collapse-level))))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:path
|
||||||
|
path))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:indent
|
||||||
|
(make-string (* mu4e-maildirs-extension-maildir-indent level)
|
||||||
|
(string-to-char mu4e-maildirs-extension-maildir-indent-char))))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:total
|
||||||
|
nil))
|
||||||
|
(setq m (plist-put m
|
||||||
|
:unread
|
||||||
|
nil))
|
||||||
|
m))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-children (m l)
|
||||||
|
"Return a list of children of M."
|
||||||
|
(let* ((path (plist-get m :path))
|
||||||
|
(sane-path (replace-regexp-in-string "\\/\\*$" "" path)))
|
||||||
|
(-filter (lambda(it)
|
||||||
|
(let* ((it-path (plist-get it :path)))
|
||||||
|
(and (not (equal it-path path))
|
||||||
|
(string-match sane-path it-path))))
|
||||||
|
l)))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-roots (l)
|
||||||
|
"Return the list of root maildirs in L."
|
||||||
|
(--filter (= (plist-get it :level) 0) l))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-member (path l)
|
||||||
|
"Return the maildir with PATH in L."
|
||||||
|
(--first (string= (plist-get it :path) path) l))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-is-parent-of (a b)
|
||||||
|
"Return t if A is parent of B."
|
||||||
|
(let ((path-a (replace-regexp-in-string "\\/\\*$"
|
||||||
|
""
|
||||||
|
(plist-get a :path)))
|
||||||
|
(path-b (replace-regexp-in-string "\\/\\*$"
|
||||||
|
""
|
||||||
|
(plist-get b :path))))
|
||||||
|
(and (not (equal path-a path-b))
|
||||||
|
(string-match path-a path-b))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-parents (m l)
|
||||||
|
"Return the list of parent maildirs of M in L."
|
||||||
|
(--filter (mu4e-maildirs-extension-is-parent-of it m) l))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-expanded (l)
|
||||||
|
"Return the list of expanded maildirs."
|
||||||
|
(-filter (lambda(m)
|
||||||
|
(let ((parents (mu4e-maildirs-extension-parents m l)))
|
||||||
|
(--all? (plist-get it :expand) parents)))
|
||||||
|
l))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-toggle-maildir-at-point (&optional universal-arg)
|
||||||
|
""
|
||||||
|
(interactive "P")
|
||||||
|
(let ((m nil)
|
||||||
|
(l mu4e-maildirs-extension-maildirs)
|
||||||
|
(marker (make-marker)))
|
||||||
|
(mu4e-maildirs-extension-with-buffer
|
||||||
|
(set-marker marker (point-at-bol)))
|
||||||
|
(setq m (--first (equal (plist-get it :marker) marker) l))
|
||||||
|
(let ((c (when m (mu4e-maildirs-extension-children m l))))
|
||||||
|
(when (and m c)
|
||||||
|
(setq m (plist-put m :expand (not (plist-get m :expand))))
|
||||||
|
(when universal-arg
|
||||||
|
(mapc (lambda(it)
|
||||||
|
(when (mu4e-maildirs-extension-children it l)
|
||||||
|
(setq it (plist-put it :expand (plist-get m :expand)))))
|
||||||
|
c))))
|
||||||
|
|
||||||
|
(mu4e-maildirs-extension-update)))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-bm-count (bm key flags)
|
||||||
|
"Fetch count results using mu FLAGS and store result in M plist with KEY"
|
||||||
|
(let* ((data (plist-get bm :data))
|
||||||
|
(cmd (mu4e-maildirs-extension-bookmark-command flags))
|
||||||
|
(count (plist-get bm key))
|
||||||
|
(callback `(lambda(result)
|
||||||
|
(let ((m (--first (equal (plist-get it :data) ',data)
|
||||||
|
mu4e-maildirs-extension-bookmarks)))
|
||||||
|
(setq m (plist-put m ,key result))))))
|
||||||
|
(unless count
|
||||||
|
(mu4e-maildirs-extension-fetch cmd callback))
|
||||||
|
(when (numberp count)
|
||||||
|
(number-to-string count))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-update ()
|
||||||
|
"Insert maildirs summary in `mu4e-main-view'."
|
||||||
|
|
||||||
|
(let ((maildirs (mu4e-maildirs-extension-load-maildirs)))
|
||||||
|
(mu4e-maildirs-extension-with-buffer
|
||||||
|
(when mu4e-maildirs-extension-use-bookmarks
|
||||||
|
(mapc #'mu4e-maildirs-extension-bm-update
|
||||||
|
(let (beg bm-points-alist)
|
||||||
|
(dolist (bm (mu4e-maildirs-extension-load-bookmarks))
|
||||||
|
(goto-char (if beg beg (point-min)))
|
||||||
|
(setq bm-name (if mu4e-maildirs-extension-mu-14
|
||||||
|
(plist-get (plist-get bm :data) :name)
|
||||||
|
(mu4e-bookmark-name (plist-get bm :data))))
|
||||||
|
(setq beg (search-forward bm-name nil t))
|
||||||
|
(push (cons bm beg) bm-points-alist))
|
||||||
|
bm-points-alist)))
|
||||||
|
(goto-char (point-max))
|
||||||
|
(cond ((and mu4e-maildirs-extension-start-point
|
||||||
|
mu4e-maildirs-extension-end-point)
|
||||||
|
(delete-region mu4e-maildirs-extension-start-point
|
||||||
|
mu4e-maildirs-extension-end-point))
|
||||||
|
(t
|
||||||
|
(setq mu4e-maildirs-extension-start-point (make-marker))
|
||||||
|
(set-marker mu4e-maildirs-extension-start-point
|
||||||
|
(search-backward mu4e-maildirs-extension-insert-before-str))
|
||||||
|
(set-marker-insertion-type mu4e-maildirs-extension-start-point nil)))
|
||||||
|
|
||||||
|
;; persistent end-point mark
|
||||||
|
(setq mu4e-maildirs-extension-end-point (make-marker))
|
||||||
|
(set-marker mu4e-maildirs-extension-end-point mu4e-maildirs-extension-start-point)
|
||||||
|
(set-marker-insertion-type mu4e-maildirs-extension-end-point t)
|
||||||
|
|
||||||
|
(goto-char mu4e-maildirs-extension-start-point)
|
||||||
|
|
||||||
|
(define-key mu4e-main-mode-map
|
||||||
|
mu4e-maildirs-extension-action-key
|
||||||
|
'mu4e-maildirs-extension-force-update)
|
||||||
|
|
||||||
|
(when mu4e-maildirs-extension-use-maildirs
|
||||||
|
(when mu4e-maildirs-extension-title
|
||||||
|
(insert "\n"
|
||||||
|
(propertize mu4e-maildirs-extension-title 'face 'mu4e-title-face)))
|
||||||
|
|
||||||
|
(cond (mu4e-maildirs-extension-queue
|
||||||
|
(insert mu4e-maildirs-extension-updating-string))
|
||||||
|
(mu4e-maildirs-extension-action-text
|
||||||
|
(insert "\n"
|
||||||
|
(mu4e~main-action-str mu4e-maildirs-extension-action-text
|
||||||
|
mu4e-maildirs-extension-action-key))))
|
||||||
|
|
||||||
|
(define-key mu4e-main-mode-map
|
||||||
|
mu4e-maildirs-extension-toggle-maildir-key
|
||||||
|
'mu4e-maildirs-extension-toggle-maildir-at-point)
|
||||||
|
|
||||||
|
(mapc #'(lambda (m)
|
||||||
|
(run-hook-with-args 'mu4e-maildirs-extension-before-insert-maildir-hook m)
|
||||||
|
(setq m (plist-put m :marker (copy-marker (point-marker))))
|
||||||
|
(mu4e-maildirs-extension-run-when-unread m #'mu4e-maildirs-extension-insert-maildir m)
|
||||||
|
(run-hook-with-args 'mu4e-maildirs-extension-after-insert-maildir-hook m))
|
||||||
|
(mu4e-maildirs-extension-expanded maildirs))))))
|
||||||
|
|
||||||
|
(defun mu4e-maildirs-extension-force-update (&optional universal-arg)
|
||||||
|
"Force update cache and summary.
|
||||||
|
Default behaviour calls `mu4e-update-index' and update cache/summary if needed.
|
||||||
|
When preceded with `universal-argument':
|
||||||
|
4 = clears the cache,
|
||||||
|
16 = clears the cache and update the summary."
|
||||||
|
(interactive "P")
|
||||||
|
(cond ((equal universal-arg nil)
|
||||||
|
(mu4e-update-index))
|
||||||
|
((equal universal-arg '(4))
|
||||||
|
(setq mu4e-maildirs-extension-bookmarks nil)
|
||||||
|
(setq mu4e-maildirs-extension-maildirs nil))
|
||||||
|
((equal universal-arg '(16))
|
||||||
|
(setq mu4e-maildirs-extension-bookmarks nil)
|
||||||
|
(setq mu4e-maildirs-extension-maildirs nil)
|
||||||
|
(mu4e-maildirs-extension-update)
|
||||||
|
(mu4e-maildirs-extension-unqueue-maybe))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun mu4e-maildirs-extension-load ()
|
||||||
|
"Initialize."
|
||||||
|
(mu4e-maildirs-extension-unload)
|
||||||
|
(if (boundp 'mu4e-message-changed-hook)
|
||||||
|
(add-hook 'mu4e-message-changed-hook mu4e-maildirs-extension-index-updated-func)
|
||||||
|
(add-hook 'mu4e-index-updated-hook mu4e-maildirs-extension-index-updated-func))
|
||||||
|
(add-hook 'mu4e-main-mode-hook mu4e-maildirs-extension-main-view-func))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun mu4e-maildirs-extension-unload ()
|
||||||
|
"Un-initialize."
|
||||||
|
(if (boundp 'mu4e-message-changed-hook)
|
||||||
|
(remove-hook 'mu4e-message-changed-hook mu4e-maildirs-extension-index-updated-func)
|
||||||
|
(remove-hook 'mu4e-index-updated-hook mu4e-maildirs-extension-index-updated-func))
|
||||||
|
(remove-hook 'mu4e-main-mode-hook mu4e-maildirs-extension-main-view-func))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defalias 'mu4e-maildirs-extension 'mu4e-maildirs-extension-load)
|
||||||
|
|
||||||
|
(provide 'mu4e-maildirs-extension)
|
||||||
|
;;; mu4e-maildirs-extension.el ends here
|
||||||
510
lisp/my.el
Normal file
510
lisp/my.el
Normal file
@@ -0,0 +1,510 @@
|
|||||||
|
;;; my.el --- Personal library -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; Org:
|
||||||
|
;; Colored text in Org buffer and export.
|
||||||
|
;; [[color:gray][text]]
|
||||||
|
;; [[color:#cccccc][text]]
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
;; ELisp:
|
||||||
|
;; (equal (symbol-name 'tmp) "tmp") ;; get symbol as string and compare with string
|
||||||
|
;; (equal (intern "tmp") 'tmp) ;; get string as symbol and compare with symbol
|
||||||
|
;; (regexp-quote "/foo/baz/*") ;; => "/foo/baz/\\*"
|
||||||
|
;; (add-hook 'help-mode-hook 'virtual-auto-fill-mode) ;; add a mode-hook
|
||||||
|
;; (add-hook 'org-mode-hook (lambda () (add-hook 'after-save-hook 'a-test-save-hook nil t))) ;; add local hook to a mode-hook
|
||||||
|
;; Org:
|
||||||
|
;; https://orgmode.org/worg/dev/org-element-api.html
|
||||||
|
;; https://orgmode.org/worg/dev/org-syntax.html
|
||||||
|
;; Over an element, like a table. The key must start with attr_.
|
||||||
|
;; The lower line shows the plist elements inside the org element context.
|
||||||
|
|
||||||
|
(defgroup my nil
|
||||||
|
"My concept mapping"
|
||||||
|
:prefix "my-"
|
||||||
|
:group 'emacs)
|
||||||
|
|
||||||
|
(defun my-list-delete (element list)
|
||||||
|
"Destructive version of `delete'.
|
||||||
|
LIST will be nil if the last ELEMENT was deleted.
|
||||||
|
Example:
|
||||||
|
(setq my-list '(\"a\"))
|
||||||
|
(my-list-delete \"a\" 'my-list)
|
||||||
|
(setq my-list '(a))
|
||||||
|
(my-list-delete 'a 'my-list)
|
||||||
|
(add-to-list 'my-list '(\"a\"))
|
||||||
|
(my-list-delete '(\"a\") 'my-list)"
|
||||||
|
(set list (delete element (symbol-value list))))
|
||||||
|
|
||||||
|
(defmacro my-plist-put (plist &rest args)
|
||||||
|
"Example usage:
|
||||||
|
(my-plist-put my-org-table-colored-cells 'table-name '(\"@23$3\" \"blue\"))
|
||||||
|
(my-plist-put my-org-table-colored-cells
|
||||||
|
'table-name-1 '(\"@13$3\" \"red\") 'table-name-2 '(\"@33$3\" \"green\"))"
|
||||||
|
(let ((list nil))
|
||||||
|
(while args
|
||||||
|
(push `(setq ,plist (plist-put ,plist ,(pop args) ,(pop args))) list))
|
||||||
|
(cons 'progn (nreverse list))))
|
||||||
|
|
||||||
|
(defun my-interpolate (low high r rlow rhigh)
|
||||||
|
"Return the point between LOW and HIGH that corresponds to where R is \
|
||||||
|
between RLOW and RHIGH.
|
||||||
|
|
||||||
|
Linear interpolate of R in the interval RLOW RHIGH.
|
||||||
|
|
||||||
|
RESULT - LOW HIGH - LOW
|
||||||
|
------------ = ------------
|
||||||
|
R - RLOW RHIGH - RLOW
|
||||||
|
|
||||||
|
HIGH - LOW
|
||||||
|
RESULT = LOW + (R - RLOW) * ------------
|
||||||
|
RHIGH - RLOW
|
||||||
|
|
||||||
|
Example:
|
||||||
|
(my-interpolate 0 100 12 0 10) => 120"
|
||||||
|
(+ low (/ (* (- high low) (- r rlow)) (- rhigh rlow))))
|
||||||
|
|
||||||
|
(defun my-color-luminance (R G B)
|
||||||
|
"Luminosity, relative luminance.
|
||||||
|
|
||||||
|
L = 0.2126*R' + 0.7152*G' + 0.0722*B' with
|
||||||
|
[R',G',B'] = [R,G,B] / 12.92 if [R,G,B] <= 0.03928 else (([R,G,B]+0.055)/1.055)^2.4
|
||||||
|
earlier
|
||||||
|
L = 0.2126*R^2.2 + 0.7152*G^2.2 + 0.0722*B^2.2
|
||||||
|
|
||||||
|
R,G,B,L = [0, 1]
|
||||||
|
See also `my-color-contrast'"
|
||||||
|
;; https://www.w3.org/Graphics/Color/sRGB.html
|
||||||
|
(let ((R (if (<= R 0.03928) (/ R 12.92) (expt (/ (+ R 0.055) 1.055) 2.4)))
|
||||||
|
(G (if (<= G 0.03928) (/ G 12.92) (expt (/ (+ G 0.055) 1.055) 2.4)))
|
||||||
|
(B (if (<= B 0.03928) (/ B 12.92) (expt (/ (+ B 0.055) 1.055) 2.4))))
|
||||||
|
(+ (* 0.2126 R) (* 0.7152 G) (* 0.0722 B)))
|
||||||
|
;; earlier
|
||||||
|
;;(+ (* 0.2126 (expt R 2.2)) (* 0.7152 (expt G 2.2)) (* 0.0722 (expt B 2.2)))
|
||||||
|
)
|
||||||
|
|
||||||
|
(defun my-color-contrast (R1 G1 B1 &optional R2 G2 B2)
|
||||||
|
"Luminosity contrast ratio.
|
||||||
|
Calculate the difference between the given colors R1, G1, B1 and R2,
|
||||||
|
G2, B2. The returned value should be greater than or equal to 4.5
|
||||||
|
\(earlier greater than 5) for best readability. Using
|
||||||
|
`my-color-luminance'. R2, G2, B2 defaults to black. See also
|
||||||
|
`color-dark-p'."
|
||||||
|
;; https://www.w3.org/TR/WCAG20/#contrast-ratiodef
|
||||||
|
;; https://www.w3.org/TR/2016/NOTE-WCAG20-TECHS-20161007/G18
|
||||||
|
(let* ((L1 (my-color-luminance R1 G1 B1))
|
||||||
|
(R2 (if R2 R2 0)) (G2 (if G2 G2 0)) (B2 (if B2 B2 0))
|
||||||
|
(L2 (my-color-luminance R2 G2 B2)))
|
||||||
|
(if (> L1 L2) ;; normally L1 defined as the lighter color and L2 as the darker color
|
||||||
|
(/ (+ L1 0.05) (+ L2 0.05))
|
||||||
|
(/ (+ L2 0.05) (+ L1 0.05)))))
|
||||||
|
|
||||||
|
(defun my-color-rgb-gradient (rgbsteps position)
|
||||||
|
"RGBSTEPS is a list of four element lists.
|
||||||
|
The list consists
|
||||||
|
- a start position value for the color d
|
||||||
|
- and the three color parameters r g b
|
||||||
|
- example
|
||||||
|
'((d1 r1 g1 b1)
|
||||||
|
(d2 r2 g2 b2)
|
||||||
|
(d3 r3 g3 b3)
|
||||||
|
(d4 r4 g4 b4))
|
||||||
|
with d1 < d2 < d3 < d4
|
||||||
|
if POSITION <= d1 then return (r1 g1 b1)
|
||||||
|
else remove the rgbstep_i where POSITION > di+1 from RGBSTEPS
|
||||||
|
if there is only one rgbstep left in RGBSTEPS return the (rn gn bn) values
|
||||||
|
otherwise interpolate of the first two rgbstep elements of the remaining
|
||||||
|
RGBSTEPS list.
|
||||||
|
|
||||||
|
Examples:
|
||||||
|
(my-rgb-gradient '((1 1 1 1) (2 2 2 2) (3 3 3 3)) 2)
|
||||||
|
(my-rgb-gradient '((1 1 1 1) (2 2 2 2)) 2)"
|
||||||
|
;; if position <= first element of first element (d1)
|
||||||
|
;; then return other elements of first element (r1 g1 b1)
|
||||||
|
(if (<= position (caar rgbsteps))
|
||||||
|
(cdar rgbsteps)
|
||||||
|
;; if there are other elements and if position > d1(,new) of the first other element
|
||||||
|
;; then remove first element
|
||||||
|
(while (and (cdr rgbsteps) (> position (caadr rgbsteps)))
|
||||||
|
(setq rgbsteps (cdr rgbsteps)))
|
||||||
|
;; if there is no other element, return other elements (rn gn bn) of the element in list
|
||||||
|
(if (null (cdr rgbsteps))
|
||||||
|
(cdar rgbsteps)
|
||||||
|
;; else there are at least two elements left.
|
||||||
|
;; return interpolation of the first two elements
|
||||||
|
(list
|
||||||
|
;; r1 g1 b1 r2 g2 b2 d1 d2
|
||||||
|
(my-interpolate (nth 1 (car rgbsteps)) (nth 1 (cadr rgbsteps)) position (caar rgbsteps) (caadr rgbsteps))
|
||||||
|
(my-interpolate (nth 2 (car rgbsteps)) (nth 2 (cadr rgbsteps)) position (caar rgbsteps) (caadr rgbsteps))
|
||||||
|
(my-interpolate (nth 3 (car rgbsteps)) (nth 3 (cadr rgbsteps)) position (caar rgbsteps) (caadr rgbsteps))))))
|
||||||
|
|
||||||
|
(with-eval-after-load 'org
|
||||||
|
|
||||||
|
;;; colored table cells
|
||||||
|
;; https://emacs.stackexchange.com/questions/7375/can-i-format-cells-in-an-org-mode-table-differently-depending-on-a-formula
|
||||||
|
(require 'ov)
|
||||||
|
|
||||||
|
(defun my-org-keywords ()
|
||||||
|
"Parse the buffer and return a cons list of (key . value)
|
||||||
|
from lines like:
|
||||||
|
#+KEY: value"
|
||||||
|
(org-element-map (org-element-parse-buffer 'greater-element) 'keyword
|
||||||
|
(lambda (keyword) (cons (org-element-property :key keyword)
|
||||||
|
(org-element-property :value keyword)))))
|
||||||
|
|
||||||
|
(defun my-org-keyword (keyword)
|
||||||
|
"Get the value of a KEYWORD in the form of #+KEYWORD: value
|
||||||
|
|
||||||
|
Using `my-org-keywords' to find all keywords."
|
||||||
|
(cdr (assoc keyword (my-org-keywords))))
|
||||||
|
|
||||||
|
(defun my-org-keyword-re (KEYWORD)
|
||||||
|
"Get the value from a line like this
|
||||||
|
#+KEYWORD: value
|
||||||
|
in a buffer.
|
||||||
|
|
||||||
|
Using a case-insensitive regular expressions search in the buffer to grab the value."
|
||||||
|
(interactive)
|
||||||
|
(let ((case-fold-search t)
|
||||||
|
(re (format "^#\\+%s:[ \t]+\\([^\t\n]+\\)" KEYWORD)))
|
||||||
|
(if (not (save-excursion
|
||||||
|
(or (re-search-forward re nil t)
|
||||||
|
(re-search-backward re nil t))))
|
||||||
|
(error (format "No line containing #+%s: value found" KEYWORD)))
|
||||||
|
(match-string 1)))
|
||||||
|
|
||||||
|
(defun my-org-attr-to-list (attr)
|
||||||
|
"
|
||||||
|
ATTR is the for example (plist-get table :attr_color)
|
||||||
|
|
||||||
|
#+ATTR_MY_KEY: this and that
|
||||||
|
:attr_my_key (\"this and that\")
|
||||||
|
|
||||||
|
#+ATTR_MY_KEY: this and that
|
||||||
|
#+ATTR_MY_KEY: foo baz
|
||||||
|
:attr_my_key (\"this and that\" \"foo baz\")"
|
||||||
|
;;(split-string (car attr)) ;; this was only the first string, meaning only one (the last) attr_color line.
|
||||||
|
;;(split-string (string-join attr " ")) ;; splits on space but also inside quotes
|
||||||
|
(split-string-and-unquote (string-join attr " ")))
|
||||||
|
|
||||||
|
(defun my-org-table-get ()
|
||||||
|
"Check if cursor is inside an Org table or on #+TBLFM lines \
|
||||||
|
then return the table element otherwise return nil.
|
||||||
|
`org-at-table-p' is nil if cursor on #+TBLFM"
|
||||||
|
(let ((element (org-element-at-point))) ;; get org element
|
||||||
|
(while (and element (not (eq (car element) 'table))) ;; check if it is table
|
||||||
|
(setq element (plist-get (cadr element) :parent))) ;; if not check if parent element is table
|
||||||
|
(cond
|
||||||
|
((equal (car element) 'table) ;; only if table found
|
||||||
|
(cadr element))))) ;; return element
|
||||||
|
|
||||||
|
(defun my-org-table-range-to-list (desc &optional val)
|
||||||
|
"
|
||||||
|
Example usage:
|
||||||
|
\(my-org-table-range-to-list \"@3$1\") -> (@3$1)
|
||||||
|
\(my-org-table-range-to-list \"@3$1\" \"red\") -> (@3$1 red)
|
||||||
|
\(my-org-table-range-to-list \"@3$1..@3$3\") -> (@3$1 @3$2 @3$3)
|
||||||
|
\(my-org-table-range-to-list \"@3$1..@3$3\" \"red\") -> (@3$1 red @3$2 red @3$3 red)
|
||||||
|
|
||||||
|
Used in `my-org-table-list-of-range-to-list'"
|
||||||
|
(if (string-match-p (regexp-quote "..") desc)
|
||||||
|
(let (from-row from-column to-row to-column result)
|
||||||
|
(string-match "@\\([0-9]+\\)\$\\([0-9]+\\)\\.\\.@\\([0-9]+\\)\$\\([0-9]+\\)" desc)
|
||||||
|
(setq from-row (string-to-number (match-string 1 desc))) ;; 1st parentheses match from string-match
|
||||||
|
(setq from-column (string-to-number (match-string 2 desc))) ;; 2nd parentheses match from string-match
|
||||||
|
(setq to-row (string-to-number (match-string 3 desc))) ;; 3rd parentheses match from string-match
|
||||||
|
(setq to-column (string-to-number (match-string 4 desc))) ;; 4th parentheses match from string-match
|
||||||
|
(loop for i upfrom to-row downto from-row ;; push prepends
|
||||||
|
do
|
||||||
|
(cl-loop for j upfrom to-column downto from-column
|
||||||
|
do
|
||||||
|
(when val (push val result)) ;; push prepends
|
||||||
|
(push (concat "@" (number-to-string i) "$" (number-to-string j)) result)
|
||||||
|
))
|
||||||
|
result)
|
||||||
|
(if val (list desc val) (list desc))))
|
||||||
|
|
||||||
|
(defun my-org-table-list-of-range-to-list (seq)
|
||||||
|
"
|
||||||
|
@3$1..@3$3 red @1$3 #0055aa -> (@3$1 red @3$2 red @3$3 red @1$3 #0055aa)
|
||||||
|
|
||||||
|
Used in `my-org-table-cell-color-attr'
|
||||||
|
uses `my-org-table-range-to-list'"
|
||||||
|
(when seq
|
||||||
|
(let (result)
|
||||||
|
;;(message "%s" seq)
|
||||||
|
(while seq
|
||||||
|
(setq result
|
||||||
|
(append result
|
||||||
|
(my-org-table-range-to-list (car seq) (cadr seq))))
|
||||||
|
(setq seq (cddr seq)))
|
||||||
|
result)))
|
||||||
|
|
||||||
|
(defun my-org-table-cell-color (beg end seq)
|
||||||
|
"BEG and END are the beginning and the end of the table.
|
||||||
|
SEQ is a list of cell name and color name pairs."
|
||||||
|
(save-excursion ;; save cursor and go back to it after, important for other features
|
||||||
|
(goto-char beg) ;; go inside the table, required for org-table-analyse
|
||||||
|
(org-table-analyze) ;; required for org-table-goto-field
|
||||||
|
(ov-clear beg end)
|
||||||
|
(while seq ;; run as long elements are in list
|
||||||
|
(let* ((cell (car seq)) ;; get first "key"
|
||||||
|
(color-name (cadr seq)) ;; get first "value"
|
||||||
|
(color-rgb (color-name-to-rgb color-name))
|
||||||
|
(bg (apply #'color-rgb-to-hex color-rgb))
|
||||||
|
;;(fg (if (>= (apply #'my-color-contrast color-rgb) 4.5) "#000000" "#ffffff"))
|
||||||
|
(fg (if (>= (apply #'my-color-contrast (append color-rgb (color-name-to-rgb "gray10"))) 4.5) "gray10" "gray80"))
|
||||||
|
;;(fg (if (>= (apply #'my-color-contrast color-rgb) 4.5) "gray10" 'default))
|
||||||
|
(beg (progn (org-table-goto-field cell) (backward-char) (point))) ;; beginning of the cell
|
||||||
|
;;(end (progn (org-table-end-of-field 1) (forward-char) (point))) ;; for left aligned cells end is end of content not of cell
|
||||||
|
(end (1- (plist-get (cadr (org-element-context)) :end)))
|
||||||
|
)
|
||||||
|
(ov beg end 'face (list :background bg
|
||||||
|
:foreground fg))
|
||||||
|
(setq seq (cddr seq)))))) ;; remove first element from list
|
||||||
|
|
||||||
|
(defvar-local my-org-table-cell-color-list
|
||||||
|
nil
|
||||||
|
"Plist of table names with list of cells to color.
|
||||||
|
It is used for the function `my-org-table-cell-color-var'.
|
||||||
|
Example usage:
|
||||||
|
(my-plist-put my-org-table-cell-color-list 'table-name '(\"@23$3\" \"blue\"))
|
||||||
|
(setq my-org-table-cell-color-list '(
|
||||||
|
table-name-1 (
|
||||||
|
\"@33$3\" \"blue\"
|
||||||
|
\"@34$2\" \"red\"
|
||||||
|
\"@34$3\" \"green\"
|
||||||
|
)
|
||||||
|
table-name-2 (\"@13$3\" \"blue\" \"@14$2\" \"red\" \"@14$3\" \"green\")
|
||||||
|
))")
|
||||||
|
|
||||||
|
(defun my-org-table-cell-color-var ()
|
||||||
|
"Function to color cells.
|
||||||
|
It uses the variable `my-org-table-cell-color-list'.
|
||||||
|
Example usage to add a (normal, global) hook:
|
||||||
|
(add-hook 'org-ctrl-c-ctrl-c-hook 'my-org-table-cell-color-var)
|
||||||
|
Example usage to add a local hook:
|
||||||
|
(add-hook 'org-ctrl-c-ctrl-c-hook 'my-org-table-cell-color-var nil t)"
|
||||||
|
(let* ((table (my-org-table-get)) ;; get table element
|
||||||
|
(table-name (plist-get table :name))) ;; get table name (string)
|
||||||
|
(cond
|
||||||
|
(table-name ;; only if table found
|
||||||
|
(let ((begcont (plist-get table :contents-begin)) ;; :begin at the beginning of #+NAME:, #+ATTR_...
|
||||||
|
(endcont (plist-get table :contents-end)) ;; :end at the end of #+TBLFM: ...
|
||||||
|
(tmp-list (plist-get my-org-table-cell-color-list (intern table-name)))) ;; get value of key (string to symbol)
|
||||||
|
(my-org-table-cell-color begcont endcont tmp-list))))))
|
||||||
|
|
||||||
|
(defun my-org-table-cell-color-attr ()
|
||||||
|
"Function to color cells.
|
||||||
|
It uses the Org keyword #+ATTR_COLOR: CELL COLOR ...
|
||||||
|
COLOR is either a color name (see `list-colors-display') or a
|
||||||
|
Multiple #+ATTR_COLOR are possible. They are joint together.
|
||||||
|
Example usage to add a (normal, global) hook:
|
||||||
|
(add-hook 'org-ctrl-c-ctrl-c-hook 'my-org-table-cell-color-attr)
|
||||||
|
Example usage to add a local hook:
|
||||||
|
(add-hook 'org-ctrl-c-ctrl-c-hook 'my-org-table-cell-color-attr nil t)
|
||||||
|
Example usage
|
||||||
|
#+ATTR_COLOR: @1$3 #0055aa @1$1 #887744 @1$2 #008822
|
||||||
|
#+ATTR_COLOR: @2$3 blue @2$1 yellow @2$2 green
|
||||||
|
#+ATTR_COLOR: @3$1..@4$3 #cc0000 @5$3 red
|
||||||
|
"
|
||||||
|
(let* ((table (my-org-table-get)) ;; get table element
|
||||||
|
(table-attr (plist-get table :attr_color))) ;; nil if attr not set, table can be nil
|
||||||
|
(cond
|
||||||
|
(table-attr ;; only if table attr found
|
||||||
|
(let ((begcont (plist-get table :contents-begin)) ;; :begin at the beginning of #+NAME:, #+ATTR_...
|
||||||
|
(endcont (plist-get table :contents-end)) ;; :end at the end of #+TBLFM: ...
|
||||||
|
(color-list
|
||||||
|
(my-org-table-list-of-range-to-list
|
||||||
|
(my-org-attr-to-list table-attr))))
|
||||||
|
(my-org-table-cell-color begcont endcont color-list))))))
|
||||||
|
|
||||||
|
;; colored text in org-mode using links
|
||||||
|
;; http://kitchingroup.cheme.cmu.edu/blog/2016/01/16/Colored-text-in-org-mode-with-export-to-HTML/
|
||||||
|
;; https://en.wikibooks.org/wiki/LaTeX/Colors
|
||||||
|
;; this will be evaluated during export
|
||||||
|
(require 'ol)
|
||||||
|
(require 'color)
|
||||||
|
(require 'ov)
|
||||||
|
(org-link-set-parameters
|
||||||
|
"color"
|
||||||
|
:follow
|
||||||
|
;;(org-add-link-type
|
||||||
|
;; "color"
|
||||||
|
'(lambda (path)
|
||||||
|
"No follow action.")
|
||||||
|
:export
|
||||||
|
'(lambda (color description backend)
|
||||||
|
"if link description is empty use color as description.
|
||||||
|
[[color:COLOR][DESCRIPTION]]"
|
||||||
|
(cond
|
||||||
|
((eq backend 'html)
|
||||||
|
(let ((rgb (color-name-to-rgb color))
|
||||||
|
r g b)
|
||||||
|
(if rgb
|
||||||
|
(progn
|
||||||
|
(setq r (truncate (* 255 (nth 0 rgb))))
|
||||||
|
(setq g (truncate (* 255 (nth 1 rgb))))
|
||||||
|
(setq b (truncate (* 255 (nth 2 rgb))))
|
||||||
|
(format "<span style=\"color: rgb(%s,%s,%s)\">%s</span>"
|
||||||
|
r g b
|
||||||
|
(or description color)))
|
||||||
|
(format "No Color RGB for %s" color))))
|
||||||
|
((eq backend 'latex)
|
||||||
|
(let ((rgb (color-name-to-rgb color)))
|
||||||
|
(if rgb
|
||||||
|
(progn
|
||||||
|
(format "\\textcolor[rgb]{%s,%s,%s}{%s}"
|
||||||
|
(nth 0 rgb) (nth 1 rgb) (nth 2 rgb)
|
||||||
|
(or description color)))
|
||||||
|
(format "No Color RGB for %s" color))))
|
||||||
|
)))
|
||||||
|
(defun my-org-link-color (limit)
|
||||||
|
"Helper function for colored text in buffer.
|
||||||
|
Usage:
|
||||||
|
[[color:gray][text]]
|
||||||
|
[[color:#cccccc][text]]"
|
||||||
|
(when (re-search-forward
|
||||||
|
"color:[#0-9a-zA-Z]\\{2,\\}" limit t)
|
||||||
|
(forward-char -2)
|
||||||
|
(let ((link (org-element-context))
|
||||||
|
color beg end post-blanks)
|
||||||
|
(if link
|
||||||
|
(progn
|
||||||
|
(setq color (org-element-property :path link)
|
||||||
|
beg (org-element-property :begin link)
|
||||||
|
end (org-element-property :end link)
|
||||||
|
post-blanks (org-element-property :post-blank link))
|
||||||
|
(set-match-data
|
||||||
|
(list beg
|
||||||
|
(- end post-blanks)))
|
||||||
|
(ov-clear beg end 'color)
|
||||||
|
(ov beg
|
||||||
|
(- end post-blanks)
|
||||||
|
'color t
|
||||||
|
'face
|
||||||
|
`((:foreground ,color)))
|
||||||
|
(goto-char end))
|
||||||
|
(goto-char limit)
|
||||||
|
nil))))
|
||||||
|
(defun my-org-link-color-hook ()
|
||||||
|
"activate with e.g. (add-hook 'org-mode-hook 'my-org-link-color-hook)"
|
||||||
|
(font-lock-add-keywords
|
||||||
|
nil
|
||||||
|
'((my-org-link-color (0 'org-link t)))
|
||||||
|
t)
|
||||||
|
)
|
||||||
|
|
||||||
|
) ;; with-eval-after-load 'org
|
||||||
|
|
||||||
|
(defun my-view-python ()
|
||||||
|
"Three windows.
|
||||||
|
On the right side a *Anaconda* buffer with optionally
|
||||||
|
`virtual-auto-fill-mode' active and a *Python* buffer."
|
||||||
|
(interactive)
|
||||||
|
(require 'python)
|
||||||
|
|
||||||
|
(unless (get-buffer (concat "*" python-shell-buffer-name "*"))
|
||||||
|
(run-python) ;; cursor is now inside the python buffer.
|
||||||
|
(other-window -1)
|
||||||
|
)
|
||||||
|
|
||||||
|
(delete-other-windows)
|
||||||
|
|
||||||
|
(split-window-horizontally (truncate (* 0.6 (window-body-width))))
|
||||||
|
(other-window 1)
|
||||||
|
(switch-to-buffer (concat "*" python-shell-buffer-name "*"))
|
||||||
|
|
||||||
|
(split-window-vertically) ;; both are python buffers now.
|
||||||
|
(switch-to-buffer "*Anaconda*")
|
||||||
|
(when (fboundp 'virtual-auto-fill-mode) (virtual-auto-fill-mode))
|
||||||
|
(other-window -1)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defun my-view-elisp ()
|
||||||
|
"Two windows side-by-side.
|
||||||
|
On the right side a *Help* buffer with optionally
|
||||||
|
`virtual-auto-fill-mode' active."
|
||||||
|
(interactive)
|
||||||
|
(delete-other-windows)
|
||||||
|
|
||||||
|
(split-window-horizontally (truncate (* 0.6 (window-body-width))))
|
||||||
|
(other-window 1)
|
||||||
|
(switch-to-buffer "*Help*")
|
||||||
|
(other-window -1)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defun my-view-shell ()
|
||||||
|
"Two windows side-by-side.
|
||||||
|
On the right side a *compilation* buffer.
|
||||||
|
Use `compile' with `sh <foo.sh -flag command>' to run the script."
|
||||||
|
;; TODO: rebind compile to C-c and auto fill sh with filename
|
||||||
|
;; TODO: rebind recompile to ??? to use last compile command
|
||||||
|
;; https://masteringemacs.org/article/compiling-running-scripts-emacs
|
||||||
|
;; TODO: for shell-script buffers:
|
||||||
|
;; ;;; Shut up compile saves
|
||||||
|
;; (setq compilation-ask-about-save nil)
|
||||||
|
;; ;;; Don't save *anything*
|
||||||
|
;; (setq compilation-save-buffers-predicate '(lambda () nil))
|
||||||
|
(interactive)
|
||||||
|
(delete-other-windows)
|
||||||
|
|
||||||
|
(split-window-horizontally (truncate (* 0.6 (window-body-width))))
|
||||||
|
(other-window 1)
|
||||||
|
(switch-to-buffer "*compilation*")
|
||||||
|
(other-window -1)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defun my-view-org-pdf ()
|
||||||
|
"Two windows side-by-side.
|
||||||
|
On the right side a DocView buffer displaying the pdf."
|
||||||
|
(interactive)
|
||||||
|
(delete-other-windows)
|
||||||
|
(let ((bufnam (buffer-name))
|
||||||
|
(buffilnam buffer-file-name))
|
||||||
|
(split-window-horizontally)
|
||||||
|
(other-window 1)
|
||||||
|
;;(switch-to-buffer (concat (file-name-sans-extension bufnam) ".pdf"))
|
||||||
|
(find-file (concat (file-name-sans-extension buffilnam) ".pdf"))
|
||||||
|
(doc-view-fit-height-to-window)
|
||||||
|
(doc-view-fit-window-to-page)
|
||||||
|
(other-window -1)
|
||||||
|
))
|
||||||
|
|
||||||
|
(defun my-view-gnuplot ()
|
||||||
|
"Three windows.
|
||||||
|
On the right side a *Shell* buffer with optionally
|
||||||
|
`virtual-auto-fill-mode' active and an Image mode buffer."
|
||||||
|
(interactive)
|
||||||
|
|
||||||
|
(save-excursion
|
||||||
|
(let (output-file-name) ;; get figure output name
|
||||||
|
(goto-char (point-min))
|
||||||
|
(when (re-search-forward "set output .*" nil t)
|
||||||
|
;; TODO: search text in between set output '...' then I do not
|
||||||
|
;; need to replace / remove part of the match string.
|
||||||
|
(setq output-file-name (match-string 0))
|
||||||
|
(setq output-file-name (string-replace "set output " "" output-file-name))
|
||||||
|
(setq output-file-name (substring output-file-name 1 -1)))
|
||||||
|
;;(message "%s" output-file-name)
|
||||||
|
|
||||||
|
(delete-other-windows)
|
||||||
|
|
||||||
|
(split-window-horizontally (truncate (* 0.6 (window-body-width))))
|
||||||
|
(other-window 1)
|
||||||
|
(if output-file-name
|
||||||
|
;;(switch-to-buffer output-file-name)
|
||||||
|
(find-file output-file-name)
|
||||||
|
;;(switch-to-buffer "*scratch*")
|
||||||
|
(switch-to-buffer " *image*"))
|
||||||
|
;;(when (fboundp 'virtual-auto-fill-mode) (virtual-auto-fill-mode))
|
||||||
|
|
||||||
|
(split-window-vertically) ;; both are shell buffers now.
|
||||||
|
(switch-to-buffer "*shell*")
|
||||||
|
(shell)
|
||||||
|
;;(when (fboundp 'virtual-auto-fill-mode) (virtual-auto-fill-mode))
|
||||||
|
|
||||||
|
(other-window -1))))
|
||||||
|
|
||||||
|
(provide 'my)
|
||||||
|
;;; my.el ends here
|
||||||
207
lisp/ob-async.el
Normal file
207
lisp/ob-async.el
Normal file
@@ -0,0 +1,207 @@
|
|||||||
|
;;; ob-async.el --- Asynchronous org-babel src block execution
|
||||||
|
|
||||||
|
;; Copyright (C) 2017 Andrew Stahlman
|
||||||
|
|
||||||
|
;; Author: Andrew Stahlman <andrewstahlman@gmail.com>
|
||||||
|
;; Created: 10 Feb 2017
|
||||||
|
;; Version: 0.1
|
||||||
|
;; Package-Version: 20190916.1537
|
||||||
|
|
||||||
|
;; Keywords: tools
|
||||||
|
;; Homepage: https://github.com/astahlman/ob-async
|
||||||
|
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;; Package-Requires: ((async "1.9") (org "9.0.1") (emacs "24.4") (dash "2.14.1"))
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;; This file enables asynchronous execution of org-babel
|
||||||
|
;; src blocks through the ob-async-org-babel-execute-src-block function
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(provide 'ob-async)
|
||||||
|
|
||||||
|
(require 'org)
|
||||||
|
(require 'async)
|
||||||
|
(require 'dash)
|
||||||
|
|
||||||
|
(defvar ob-async-no-async-languages-alist nil
|
||||||
|
"async is not used for languages listed here. Enables
|
||||||
|
compatibility for other languages, e.g. ipython, for which async
|
||||||
|
functionality may be implemented separately.")
|
||||||
|
|
||||||
|
(defvar ob-async-pre-execute-src-block-hook nil
|
||||||
|
"Hook run in the async child process prior to executing a src
|
||||||
|
block. You can use this hook to perform language-specific
|
||||||
|
initialization which would normally execute in your init file.")
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defalias 'org-babel-execute-src-block:async 'ob-async-org-babel-execute-src-block)
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun ob-async-org-babel-execute-src-block (&optional orig-fun arg info params)
|
||||||
|
"Like org-babel-execute-src-block, but run asynchronously.
|
||||||
|
|
||||||
|
Original docstring for org-babel-execute-src-block:
|
||||||
|
|
||||||
|
Execute the current source code block. Insert the results of
|
||||||
|
execution into the buffer. Source code execution and the
|
||||||
|
collection and formatting of results can be controlled through a
|
||||||
|
variety of header arguments.
|
||||||
|
|
||||||
|
With prefix argument ARG, force re-execution even if an existing
|
||||||
|
result cached in the buffer would otherwise have been returned.
|
||||||
|
|
||||||
|
Optionally supply a value for INFO in the form returned by
|
||||||
|
`org-babel-get-src-block-info'.
|
||||||
|
|
||||||
|
Optionally supply a value for PARAMS which will be merged with
|
||||||
|
the header arguments specified at the front of the source code
|
||||||
|
block."
|
||||||
|
(interactive "P")
|
||||||
|
(cond
|
||||||
|
;; If this function is not called as advice, do nothing
|
||||||
|
((not orig-fun)
|
||||||
|
(warn "ob-async-org-babel-execute-src-block is no longer needed in org-ctrl-c-ctrl-c-hook")
|
||||||
|
nil)
|
||||||
|
;; If there is no :async parameter, call the original function
|
||||||
|
((not (assoc :async (nth 2 (or info (org-babel-get-src-block-info)))))
|
||||||
|
(funcall orig-fun arg info params))
|
||||||
|
;; If the src block language is in the list of languages async is not to be
|
||||||
|
;; used for, call the original function
|
||||||
|
((member (nth 0 (or info (org-babel-get-src-block-info)))
|
||||||
|
ob-async-no-async-languages-alist)
|
||||||
|
(funcall orig-fun arg info params))
|
||||||
|
;; Otherwise, perform asynchronous execution
|
||||||
|
(t
|
||||||
|
(let ((placeholder (ob-async--generate-uuid)))
|
||||||
|
;; Here begins the original source of org-babel-execute-src-block
|
||||||
|
(let* ((org-babel-current-src-block-location
|
||||||
|
(or org-babel-current-src-block-location
|
||||||
|
(nth 5 info)
|
||||||
|
(org-babel-where-is-src-block-head)))
|
||||||
|
(src-block-marker (save-excursion
|
||||||
|
(goto-char org-babel-current-src-block-location)
|
||||||
|
(point-marker)))
|
||||||
|
(info (if info (copy-tree info) (org-babel-get-src-block-info))))
|
||||||
|
;; Merge PARAMS with INFO before considering source block
|
||||||
|
;; evaluation since both could disagree.
|
||||||
|
(cl-callf org-babel-merge-params (nth 2 info) params)
|
||||||
|
(when (org-babel-check-evaluate info)
|
||||||
|
(cl-callf org-babel-process-params (nth 2 info))
|
||||||
|
(let* ((params (nth 2 info))
|
||||||
|
(cache (let ((c (cdr (assq :cache params))))
|
||||||
|
(and (not arg) c (string= "yes" c))))
|
||||||
|
(new-hash (and cache (org-babel-sha1-hash info)))
|
||||||
|
(old-hash (and cache (org-babel-current-result-hash)))
|
||||||
|
(current-cache (and new-hash (equal new-hash old-hash)))
|
||||||
|
(result-params (cdr (assq :result-params params))))
|
||||||
|
(cond
|
||||||
|
(current-cache
|
||||||
|
(save-excursion ;Return cached result.
|
||||||
|
(goto-char (org-babel-where-is-src-block-result nil info))
|
||||||
|
(forward-line)
|
||||||
|
(skip-chars-forward " \t")
|
||||||
|
(let ((result (org-babel-read-result)))
|
||||||
|
(message (replace-regexp-in-string "%" "%%" (format "%S" result)))
|
||||||
|
result)))
|
||||||
|
((org-babel-confirm-evaluate info)
|
||||||
|
;; Insert a GUID as a placeholder in our RESULTS block
|
||||||
|
(when (not (or (member "none" result-params)
|
||||||
|
(member "silent" result-params)))
|
||||||
|
(org-babel-insert-result placeholder '("replace")))
|
||||||
|
(let* ((lang (nth 0 info))
|
||||||
|
;; Expand noweb references in BODY and remove any
|
||||||
|
;; coderef.
|
||||||
|
(body
|
||||||
|
(let ((coderef (nth 6 info))
|
||||||
|
(expand
|
||||||
|
(if (org-babel-noweb-p params :eval)
|
||||||
|
(org-babel-expand-noweb-references info)
|
||||||
|
(nth 1 info))))
|
||||||
|
(if (not coderef) expand
|
||||||
|
(replace-regexp-in-string
|
||||||
|
(org-src-coderef-regexp coderef) "" expand nil nil 1))))
|
||||||
|
(dir (cdr (assq :dir params)))
|
||||||
|
(default-directory
|
||||||
|
(or (and dir (file-name-as-directory (expand-file-name dir)))
|
||||||
|
default-directory))
|
||||||
|
(cmd (intern (concat "org-babel-execute:" lang)))
|
||||||
|
result)
|
||||||
|
(unless (fboundp cmd)
|
||||||
|
(error "No org-babel-execute function for %s!" lang))
|
||||||
|
(message "executing %s code block%s..."
|
||||||
|
(capitalize lang)
|
||||||
|
(let ((name (nth 4 info)))
|
||||||
|
(if name (format " (%s)" name) "")))
|
||||||
|
(progn
|
||||||
|
(async-start
|
||||||
|
`(lambda ()
|
||||||
|
;; TODO: Put this in a function so it can be overidden
|
||||||
|
;; Initialize the new Emacs process with org-babel functions
|
||||||
|
(setq exec-path ',exec-path)
|
||||||
|
(setq load-path ',load-path)
|
||||||
|
(package-initialize)
|
||||||
|
(setq ob-async-pre-execute-src-block-hook ',ob-async-pre-execute-src-block-hook)
|
||||||
|
(run-hooks 'ob-async-pre-execute-src-block-hook)
|
||||||
|
(org-babel-do-load-languages 'org-babel-load-languages ',org-babel-load-languages)
|
||||||
|
(let ((default-directory ,default-directory))
|
||||||
|
(,cmd ,body ',params)))
|
||||||
|
`(lambda (result)
|
||||||
|
(with-current-buffer ,(current-buffer)
|
||||||
|
(let ((default-directory ,default-directory))
|
||||||
|
(save-excursion
|
||||||
|
(cond
|
||||||
|
((member "none" ',result-params)
|
||||||
|
(message "result silenced"))
|
||||||
|
((member "silent" ',result-params)
|
||||||
|
(message (replace-regexp-in-string "%" "%%" (format "%S" result))))
|
||||||
|
(t
|
||||||
|
(goto-char ,src-block-marker)
|
||||||
|
(let ((file (cdr (assq :file ',params))))
|
||||||
|
(when file
|
||||||
|
;; when result type is link, don't write result content to file.
|
||||||
|
(unless (member "link" ',result-params)
|
||||||
|
;; If non-empty result and :file then write to :file.
|
||||||
|
(when result
|
||||||
|
(with-temp-file file
|
||||||
|
(insert (org-babel-format-result
|
||||||
|
result (cdr (assq :sep ',params)))))))
|
||||||
|
(setq result file))
|
||||||
|
;; Possibly perform post process provided its
|
||||||
|
;; appropriate. Dynamically bind "*this*" to the
|
||||||
|
;; actual results of the block.
|
||||||
|
(let ((post (cdr (assq :post ',params))))
|
||||||
|
(when post
|
||||||
|
(let ((*this* (if (not file) result
|
||||||
|
(org-babel-result-to-file
|
||||||
|
file
|
||||||
|
(let ((desc (assq :file-desc ',params)))
|
||||||
|
(and desc (or (cdr desc) result)))))))
|
||||||
|
(setq result (org-babel-ref-resolve post))
|
||||||
|
(when file
|
||||||
|
(setq result-params (remove "file" ',result-params))))))
|
||||||
|
(org-babel-insert-result result ',result-params ',info ',new-hash ',lang))))
|
||||||
|
(run-hooks 'org-babel-after-execute-hook)))))))))))))))))
|
||||||
|
|
||||||
|
(defun ob-async--generate-uuid ()
|
||||||
|
"Generate a 32 character UUID."
|
||||||
|
(md5 (number-to-string (random 100000000))))
|
||||||
|
|
||||||
|
(advice-add 'org-babel-execute-src-block :around 'ob-async-org-babel-execute-src-block)
|
||||||
|
|
||||||
|
;;; ob-async.el ends here
|
||||||
3467
lisp/org-brain.el
Normal file
3467
lisp/org-brain.el
Normal file
File diff suppressed because it is too large
Load Diff
3860
lisp/org-drill.el
Normal file
3860
lisp/org-drill.el
Normal file
File diff suppressed because it is too large
Load Diff
148
lisp/org-fancy-priorities.el
Normal file
148
lisp/org-fancy-priorities.el
Normal file
@@ -0,0 +1,148 @@
|
|||||||
|
;;; org-fancy-priorities.el --- Display org priorities as custom strings
|
||||||
|
;;
|
||||||
|
;; Copyright (C) 2018 Harry Bournis
|
||||||
|
;;
|
||||||
|
;; Author: Harry Bournis <harrybournis@gmail.com>
|
||||||
|
;; Created: 5 Feb 2018
|
||||||
|
;; Version: 1.1
|
||||||
|
;; Package-Version: 20180328.2331
|
||||||
|
;; Package-Commit: 819bb993b71e7253cefef7047306ab4e0f9d0a86
|
||||||
|
;; Keywords: convenience faces outlines
|
||||||
|
;; Homepage: https://github.com/harrybournis/org-fancy-priorities
|
||||||
|
;;
|
||||||
|
;; 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 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., 59 Temple Place, Suite 330, Boston,
|
||||||
|
;; MA 02111-1307 USA
|
||||||
|
;;
|
||||||
|
;;; Commentary:
|
||||||
|
;;
|
||||||
|
;; Org mode is great. It is powerful, versatile and customizable. Unfortunately, I
|
||||||
|
;; always found the task priorities functionality a bit underwhelming, not in
|
||||||
|
;; terms of usability, but more in the visual department.
|
||||||
|
;;
|
||||||
|
;; Inspired by https://github.com/sabof/org-bullets, I created a
|
||||||
|
;; minor mode that displays org priorities as custom strings. This mode does
|
||||||
|
;; NOT change your files in any way, it only displays the priority part of a
|
||||||
|
;; heading as your preferred string value.
|
||||||
|
;;
|
||||||
|
;; Set the org-fancy-priorities-list variable either with a list of strings in descending
|
||||||
|
;; priority importance, or an alist that maps each priority character to a custom string.
|
||||||
|
;;
|
||||||
|
;; (setq org-fancy-priorities-list '("HIGH" "MID" "LOW" "OPTIONAL"))
|
||||||
|
;;
|
||||||
|
;; or
|
||||||
|
;;
|
||||||
|
;; (setq org-fancy-priorities-list '((?A . "❗")
|
||||||
|
;; (?B . "⬆")
|
||||||
|
;; (?C . "⬇")
|
||||||
|
;; (?D . "☕")
|
||||||
|
;; (?1 . "⚡")
|
||||||
|
;; (?2 . "⮬")
|
||||||
|
;; (?3 . "⮮")
|
||||||
|
;; (?4 . "☕")
|
||||||
|
;; (?I . "Important")))
|
||||||
|
;;
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(eval-when-compile
|
||||||
|
(require 'org))
|
||||||
|
|
||||||
|
(defgroup org-fancy-priorities nil
|
||||||
|
"Display org priorities as custom strings"
|
||||||
|
:group 'org-appearance
|
||||||
|
:version "1.1")
|
||||||
|
|
||||||
|
(defcustom org-fancy-priorities-list
|
||||||
|
'("❗" "⬆" "⬇" "☕")
|
||||||
|
;; or
|
||||||
|
;; '((?A . "❗")
|
||||||
|
;; (?B . "⬆")
|
||||||
|
;; (?C . "⬇")
|
||||||
|
;; (?D . "☕")
|
||||||
|
;; (?1 . "❗")
|
||||||
|
;; (?2 . "⮬")
|
||||||
|
;; (?3 . "⮮")
|
||||||
|
;; (?4 . "☠"))
|
||||||
|
"The list of custom strings that will appear instead of the org mode defaults.
|
||||||
|
Like with org priorities, it starts with the highest priority and decreases in severity.
|
||||||
|
|
||||||
|
Note that you have to include the question mark before the character even if it is a
|
||||||
|
number, or you won't get the correct ascii value."
|
||||||
|
:group 'org-fancy-priorities
|
||||||
|
:type '(choice (repeat :tag "Same symbols for all files" (string))
|
||||||
|
(repeat :tag "Custom symbol for each priority value" (cons integer string))))
|
||||||
|
|
||||||
|
(defvar org-fancy-priorities-regex
|
||||||
|
".*?\\(\\[#\\([A-Z0-9]\\)\\] ?\\)"
|
||||||
|
"The regex used to find org mode priorities.")
|
||||||
|
|
||||||
|
(defvar org-fancy-priorities-overlay-list
|
||||||
|
'()
|
||||||
|
"Used to keep track of created overlays.")
|
||||||
|
|
||||||
|
(defun org-fancy-priorities-get-value (priority)
|
||||||
|
"Return the string that will appear instead of the PRIORITY arg.
|
||||||
|
Return nil if a value has not been specified for this priority.
|
||||||
|
PRIORITY Is a string of just the priority value e.g. \"A\" \"B\" etc."
|
||||||
|
(let ((priority-int (string-to-char priority)))
|
||||||
|
;; Check if org-fancy-priorities-list is a list of strings or alists
|
||||||
|
(cond ((equal 'string (type-of (car org-fancy-priorities-list)))
|
||||||
|
(let ((index (- priority-int org-highest-priority)))
|
||||||
|
(if (< index (length org-fancy-priorities-list))
|
||||||
|
(nth index org-fancy-priorities-list)
|
||||||
|
(format "[#%s]" priority))))
|
||||||
|
|
||||||
|
((equal 'cons (type-of (car org-fancy-priorities-list)))
|
||||||
|
(let ((value (cdr (assq priority-int org-fancy-priorities-list))))
|
||||||
|
(if value
|
||||||
|
value
|
||||||
|
(format "[#%s]" priority))))
|
||||||
|
|
||||||
|
(t (display-warning '(org-fancy-priorities) "Invalid org-fancy-priorities-list value" :error)))))
|
||||||
|
|
||||||
|
(defun org-fancy-priorities-create-overlays ()
|
||||||
|
"Search with regex for priorities and add an overlay with their replacement string on their position."
|
||||||
|
(let (ol)
|
||||||
|
(while (re-search-forward org-fancy-priorities-regex nil t)
|
||||||
|
(setq ol (make-overlay (match-beginning 1) (- (match-end 1) 1)))
|
||||||
|
(overlay-put ol 'display (org-fancy-priorities-get-value (match-string 2)))
|
||||||
|
(push ol org-fancy-priorities-overlay-list))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(define-minor-mode org-fancy-priorities-mode
|
||||||
|
"Customize the appearance of org-mode priorities.
|
||||||
|
This mode does not alter your files in any way, it
|
||||||
|
only changes the way that priorities are shown in your editor."
|
||||||
|
nil " FancyPriorities" nil
|
||||||
|
(let ((keyword `((,org-fancy-priorities-regex
|
||||||
|
(0 (progn
|
||||||
|
(let ((custom-priority (org-fancy-priorities-get-value (match-string 2))))
|
||||||
|
(put-text-property (match-beginning 1) (- (match-end 1) 1) 'display custom-priority)
|
||||||
|
nil)))))))
|
||||||
|
(if org-fancy-priorities-mode
|
||||||
|
(progn
|
||||||
|
(add-hook 'org-agenda-finalize-hook 'org-fancy-priorities-create-overlays)
|
||||||
|
(font-lock-add-keywords nil keyword))
|
||||||
|
(progn
|
||||||
|
(remove-hook 'org-agenda-finalize-hook 'org-fancy-priorities-create-overlays)
|
||||||
|
(dolist (ol org-fancy-priorities-overlay-list) (delete-overlay ol))
|
||||||
|
(font-lock-remove-keywords nil keyword)
|
||||||
|
(remove-text-properties (buffer-end -1) (buffer-end 1) '(display nil))))
|
||||||
|
(with-no-warnings (font-lock-fontify-buffer))))
|
||||||
|
|
||||||
|
(provide 'org-fancy-priorities)
|
||||||
|
|
||||||
|
;;; org-fancy-priorities.el ends here
|
||||||
225
lisp/org-sticky-header.el
Normal file
225
lisp/org-sticky-header.el
Normal file
@@ -0,0 +1,225 @@
|
|||||||
|
;;; org-sticky-header.el --- Show off-screen Org heading at top of window -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Author: Adam Porter <adam@alphapapa.net>
|
||||||
|
;; Url: http://github.com/alphapapa/org-sticky-header
|
||||||
|
;; Package-Version: 20191117.549
|
||||||
|
;; Package-Commit: 1053ebdeb3bd14fc8d4538643532efb86d18b73c
|
||||||
|
;; Version: 1.1-pre
|
||||||
|
;; Package-Requires: ((emacs "24.4") (org "8.3.5"))
|
||||||
|
;; Keywords: hypermedia, outlines, Org
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; This package displays in the header-line the Org heading for the
|
||||||
|
;; node that's at the top of the window. This way, if the heading for
|
||||||
|
;; the text at the top of the window is beyond the top of the window,
|
||||||
|
;; you don't forget which heading the text belongs to.
|
||||||
|
|
||||||
|
;; The code is very simple and is based on `semantic-stickyfunc-mode'.
|
||||||
|
|
||||||
|
;;; Installation:
|
||||||
|
|
||||||
|
;; Install from MELPA and run `org-sticky-header-mode'.
|
||||||
|
|
||||||
|
;; To install manually, put this file in your `load-path', require
|
||||||
|
;; `org-sticky-header' in your init file, and run the same command.
|
||||||
|
|
||||||
|
;; You probably want to add `org-sticky-header-mode' to your `org-mode-hook'.
|
||||||
|
|
||||||
|
;; By default, the line will be indented like a real headline. To
|
||||||
|
;; change this, configure `org-sticky-header-prefix'.
|
||||||
|
|
||||||
|
;;; 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 of the License, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;;;; Requirements
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'org)
|
||||||
|
|
||||||
|
;;;; Variables
|
||||||
|
|
||||||
|
(defvar org-sticky-header-old-hlf nil
|
||||||
|
"Value of the header line when entering org-sticky-header mode.")
|
||||||
|
|
||||||
|
(defvar-local org-sticky-header-stickyline nil
|
||||||
|
"Value of header line")
|
||||||
|
(put 'org-sticky-header-stickyline 'risky-local-variable t)
|
||||||
|
|
||||||
|
(defvar org-sticky-header-keymap
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(define-key map (kbd "<header-line> <mouse-1>") #'org-sticky-header-goto-heading)
|
||||||
|
map)
|
||||||
|
"Keymap used in header line.")
|
||||||
|
|
||||||
|
(defconst org-sticky-header-header-line-format
|
||||||
|
'(:eval (progn
|
||||||
|
(setq org-sticky-header-stickyline
|
||||||
|
(propertize (org-sticky-header--fetch-stickyline)
|
||||||
|
'keymap org-sticky-header-keymap))
|
||||||
|
(list
|
||||||
|
(propertize " " 'display '((space :align-to 0)))
|
||||||
|
'org-sticky-header-stickyline)))
|
||||||
|
"The header line format used by stickyfunc mode.")
|
||||||
|
|
||||||
|
(defgroup org-sticky-header nil
|
||||||
|
"Options for `org-sticky-header-mode'."
|
||||||
|
:group 'org)
|
||||||
|
|
||||||
|
(defcustom org-sticky-header-full-path nil
|
||||||
|
"Show the full outline path."
|
||||||
|
:type '(radio (const :tag "Show only current heading" nil)
|
||||||
|
(const :tag "Show full outline path to current heading" full)
|
||||||
|
(const :tag "Show full outline path, but reversed so current heading is first" reversed)))
|
||||||
|
|
||||||
|
(defcustom org-sticky-header-always-show-header t
|
||||||
|
"Show the header even when the top line of the buffer is a heading.
|
||||||
|
When this is on, and the top line of the buffer is a heading,
|
||||||
|
you'll see the heading shown twice: once in the header and once
|
||||||
|
in the buffer. But since the header can look different than the
|
||||||
|
heading (i.e. it can show the full path), it shouldn't
|
||||||
|
necessarily disappear. If you use full-path display, you probably
|
||||||
|
want this on, but if you only display the current heading, you
|
||||||
|
might prefer to turn it off. "
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
(defcustom org-sticky-header-prefix 'org-sticky-header--indent-prefix
|
||||||
|
"Prefix to display before heading in header line.
|
||||||
|
`org-indent-mode' users should use the default function. Custom
|
||||||
|
functions will be run with point on a heading."
|
||||||
|
:type '(choice (function-item :tag "Like real headline" org-sticky-header--indent-prefix)
|
||||||
|
(string :tag "Custom string" :value " ")
|
||||||
|
(function :tag "Custom function which returns a string")
|
||||||
|
(const :tag "None" nil)))
|
||||||
|
|
||||||
|
(defcustom org-sticky-header-outline-path-separator "/"
|
||||||
|
"String displayed between elements of outline paths."
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
(defcustom org-sticky-header-outline-path-reversed-separator "\\"
|
||||||
|
"String displayed between elements of reversed outline paths."
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
(defcustom org-sticky-header-heading-star "*"
|
||||||
|
"String to show before heading.
|
||||||
|
By default, show an asterisk, like in an Org buffer. Changing
|
||||||
|
this to something else may help distinguish the header line from
|
||||||
|
headings in the buffer when `org-sticky-header-always-show-header'
|
||||||
|
is enabled."
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
;;;; Functions
|
||||||
|
|
||||||
|
(defun org-sticky-header-goto-heading (event)
|
||||||
|
"Go to heading displayed in sticky header (for click event EVENT)."
|
||||||
|
(interactive "e")
|
||||||
|
(with-selected-window (posn-window (event-start event))
|
||||||
|
(goto-char (window-start))
|
||||||
|
(unless (org-before-first-heading-p)
|
||||||
|
(org-back-to-heading))))
|
||||||
|
|
||||||
|
(defun org-sticky-header--fetch-stickyline ()
|
||||||
|
"Return string of Org heading or outline path for display in header line."
|
||||||
|
(org-with-wide-buffer
|
||||||
|
(goto-char (window-start))
|
||||||
|
(unless (org-before-first-heading-p)
|
||||||
|
;; No non-header lines above top displayed header
|
||||||
|
(when (or org-sticky-header-always-show-header
|
||||||
|
(not (org-at-heading-p)))
|
||||||
|
;; Header should be shown
|
||||||
|
(when (fboundp 'org-inlinetask-in-task-p)
|
||||||
|
;; Skip inline tasks
|
||||||
|
(while (and (org-back-to-heading)
|
||||||
|
(org-inlinetask-in-task-p))
|
||||||
|
(forward-line -1)))
|
||||||
|
(cond
|
||||||
|
;; FIXME: Convert cond back to pcase, but one compatible with Emacs 24
|
||||||
|
((null org-sticky-header-full-path)
|
||||||
|
(concat (org-sticky-header--get-prefix)
|
||||||
|
(org-get-heading t t)))
|
||||||
|
((eq org-sticky-header-full-path 'full)
|
||||||
|
(concat (org-sticky-header--get-prefix)
|
||||||
|
(org-format-outline-path (org-get-outline-path t)
|
||||||
|
(window-width)
|
||||||
|
nil org-sticky-header-outline-path-separator)))
|
||||||
|
((eq org-sticky-header-full-path 'reversed)
|
||||||
|
(let ((s (concat (org-sticky-header--get-prefix)
|
||||||
|
(mapconcat 'identity
|
||||||
|
(nreverse (org-split-string (org-format-outline-path (org-get-outline-path t)
|
||||||
|
1000 nil " ")
|
||||||
|
" "))
|
||||||
|
org-sticky-header-outline-path-reversed-separator))))
|
||||||
|
(if (> (length s) (window-width))
|
||||||
|
(concat (substring s 0 (- (window-width) 2))
|
||||||
|
"..")
|
||||||
|
s)))
|
||||||
|
(t nil))))))
|
||||||
|
|
||||||
|
(defun org-sticky-header--get-prefix ()
|
||||||
|
"Return prefix string depending on value of `org-sticky-header-prefix'."
|
||||||
|
(cl-typecase org-sticky-header-prefix
|
||||||
|
(function (funcall org-sticky-header-prefix))
|
||||||
|
(string org-sticky-header-prefix)
|
||||||
|
(nil nil)))
|
||||||
|
|
||||||
|
(defun org-sticky-header--indent-prefix ()
|
||||||
|
"Return indentation prefix for heading at point.
|
||||||
|
This will do the right thing both with and without `org-indent-mode'."
|
||||||
|
;; Modelled after `org-indent-set-line-properties'
|
||||||
|
(let* ((level (org-current-level))
|
||||||
|
(indent-mode (bound-and-true-p org-indent-mode))
|
||||||
|
(npre (if (<= level 1) 0
|
||||||
|
(+ (if indent-mode
|
||||||
|
(* (1- org-indent-indentation-per-level)
|
||||||
|
(1- level))
|
||||||
|
0)
|
||||||
|
level -1)))
|
||||||
|
(prefix (concat (make-string npre (if indent-mode ?\ ?*)) org-sticky-header-heading-star " ")))
|
||||||
|
(org-add-props prefix nil 'face
|
||||||
|
(if org-cycle-level-faces
|
||||||
|
(setq org-f (nth (% (1- level) org-n-level-faces) org-level-faces))
|
||||||
|
(setq org-f (nth (1- (min level org-n-level-faces)) org-level-faces))))))
|
||||||
|
|
||||||
|
;;;; Minor mode
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(define-minor-mode org-sticky-header-mode
|
||||||
|
"Minor mode to show the current Org heading in the header line.
|
||||||
|
With prefix argument ARG, turn on if positive, otherwise off.
|
||||||
|
Return non-nil if the minor mode is enabled."
|
||||||
|
:group 'org
|
||||||
|
(if org-sticky-header-mode
|
||||||
|
(progn
|
||||||
|
(when (and (local-variable-p 'header-line-format (current-buffer))
|
||||||
|
(not (eq header-line-format org-sticky-header-header-line-format)))
|
||||||
|
;; Save previous buffer local value of header line format.
|
||||||
|
(set (make-local-variable 'org-sticky-header-old-hlf)
|
||||||
|
header-line-format))
|
||||||
|
;; Enable the mode
|
||||||
|
(setq header-line-format org-sticky-header-header-line-format))
|
||||||
|
;; Disable mode
|
||||||
|
(when (eq header-line-format org-sticky-header-header-line-format)
|
||||||
|
;; Restore previous buffer local value of header line format if
|
||||||
|
;; the current one is the sticky func one.
|
||||||
|
(kill-local-variable 'header-line-format)
|
||||||
|
(when (local-variable-p 'org-sticky-header-old-hlf (current-buffer))
|
||||||
|
(setq header-line-format org-sticky-header-old-hlf)
|
||||||
|
(kill-local-variable 'org-sticky-header-old-hlf)))))
|
||||||
|
|
||||||
|
(provide 'org-sticky-header)
|
||||||
|
|
||||||
|
;;; org-sticky-header.el ends here
|
||||||
689
lisp/org-superstar.el
Normal file
689
lisp/org-superstar.el
Normal file
@@ -0,0 +1,689 @@
|
|||||||
|
;;; org-superstar.el --- Prettify headings and plain lists in Org mode -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2020 D. Williams, sabof
|
||||||
|
|
||||||
|
;; Author: D. Williams <d.williams@posteo.net>
|
||||||
|
;; Maintainer: D. Williams <d.williams@posteo.net>
|
||||||
|
;; Keywords: faces, outlines
|
||||||
|
;; Package-Version: 20200616.1633
|
||||||
|
;; Package-Commit: 17481852c1bd09afea877635a3185261fc19fd64
|
||||||
|
;; Version: 1.2.1
|
||||||
|
;; Homepage: https://github.com/integral-dw/org-superstar-mode
|
||||||
|
;; Package-Requires: ((org "9.1.9") (emacs "26.1"))
|
||||||
|
|
||||||
|
;; 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 <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Prettify headings and plain lists in org-mode. This package is a
|
||||||
|
;; direct descendant of ‘org-bullets’, with most of the code base
|
||||||
|
;; completely rewritten (See https://github.com/sabof/org-bullets).
|
||||||
|
;; Currently, this package supports:
|
||||||
|
|
||||||
|
;; * Prettifying org heading lines by:
|
||||||
|
;; + replacing trailing bullets by UTF-8 bullets
|
||||||
|
;; + hiding leading stars, customizing their look or removing them
|
||||||
|
;; from vision
|
||||||
|
;; + applying a custom face to the header bullet
|
||||||
|
;; + applying a custom face to the leading bullets
|
||||||
|
;; + using double-bullets for inline tasks (see org-inlinetask.el)
|
||||||
|
;; + (optional) using special bullets for TODO keywords
|
||||||
|
;; * Prettifying org plain list bullets by:
|
||||||
|
;; + replacing each bullet type (*, + and -) with UTF-8 bullets
|
||||||
|
;; + applying a custom face to item bullets
|
||||||
|
;; * Gracefully degrading features when viewed from terminal
|
||||||
|
|
||||||
|
;; This package is heavily influenced by (and uses snippets from) the
|
||||||
|
;; popular package "org-bullets", created by sabof. It was made with
|
||||||
|
;; the goal of inheriting features the author liked about org-bullets
|
||||||
|
;; while being able to introduce compatibility-breaking changes to it.
|
||||||
|
;; It is largely rewritten, to the point of almost no function being
|
||||||
|
;; identical to it's org-bullets counterpart.
|
||||||
|
|
||||||
|
;; This package is versioned using (the author's understanding of)
|
||||||
|
;; semantic versioning: "<major>.<minor>.<patch>".
|
||||||
|
;; <major> version increments signify backward incompatible changes.
|
||||||
|
;; <minor> version increments signify backward compatible but
|
||||||
|
;; significant changes.
|
||||||
|
;; <patch> version increments signify changes not affecting the API.
|
||||||
|
|
||||||
|
;; Here are some Unicode blocks which are generally nifty resources
|
||||||
|
;; for this package:
|
||||||
|
;;
|
||||||
|
;; General Punctuation (U+2000-U+206F): Bullets, leaders, asterisms.
|
||||||
|
;; Dingbats (U+2700-U+27BF)
|
||||||
|
;; Miscellaneous Symbols and Arrows (U+2B00-U+2BFF):
|
||||||
|
;; Further stars and arrowheads.
|
||||||
|
;; Miscellaneous Symbols (U+2600–U+26FF): Smileys and card suits.
|
||||||
|
;; Supplemental Arrows-C (U+1F800-U+1F8FF)
|
||||||
|
;; Geometric Shapes (U+25A0-U+25FF): Circles, shapes within shapes.
|
||||||
|
;; Geometric Shapes Extended (U+1F780-U+1F7FF):
|
||||||
|
;; More of the above, and stars.
|
||||||
|
;;
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'org)
|
||||||
|
(require 'org-element)
|
||||||
|
(require 'wid-edit)
|
||||||
|
|
||||||
|
(defgroup org-superstar nil
|
||||||
|
"Use UTF8 bullets for headlines and plain lists."
|
||||||
|
:group 'org-appearance)
|
||||||
|
|
||||||
|
;;; Bullet Variables
|
||||||
|
|
||||||
|
(defcustom org-superstar-headline-bullets-list
|
||||||
|
'(;; Original ones nicked from org-bullets
|
||||||
|
"◉"
|
||||||
|
"○"
|
||||||
|
"✸"
|
||||||
|
"✿") ;; "◉" "🞛" "○" "▷"
|
||||||
|
"List of bullets used in Org headings.
|
||||||
|
It can contain any number of bullets, the Nth entry usually
|
||||||
|
corresponding to the bullet used for level N. The way this list
|
||||||
|
is cycled through can use fine-tuned by customizing
|
||||||
|
‘org-superstar-cycle-headline-bullets’.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(repeat (string :tag "Bullet character")))
|
||||||
|
|
||||||
|
(defcustom org-superstar-item-bullet-alist
|
||||||
|
'((?* . ?•)
|
||||||
|
(?+ . ?➤)
|
||||||
|
(?- . ?–))
|
||||||
|
"Alist of UTF-8 bullets to be used for plain org lists.
|
||||||
|
Each key should be a plain list bullet character (*,+,-), and
|
||||||
|
each value should be the UTF8 character to be displayed.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(alist :options ((?* (character))
|
||||||
|
(?+ (character))
|
||||||
|
(?- (character)))))
|
||||||
|
|
||||||
|
(defcustom org-superstar-todo-bullet-alist
|
||||||
|
'(("TODO" . ?☐)
|
||||||
|
("DONE" . ?☑))
|
||||||
|
"Alist of UTF-8 bullets for TODO items.
|
||||||
|
|
||||||
|
In the simplest case each key should be a TODO keyword, and each
|
||||||
|
value should the UTF8 character to be displayed. Keywords that
|
||||||
|
are not included in the alist are handled like normal headings.
|
||||||
|
|
||||||
|
Alternatively, each alist element may be a proper list of the form
|
||||||
|
\(KEYWORD COMPOSE-STRING CHARACTER [REST...])
|
||||||
|
|
||||||
|
where KEYWORD should be a TODO keyword, and COMPOSE-STRING should
|
||||||
|
be a string according to the rules of the third argument of
|
||||||
|
‘compose-region’. It will be used to compose the specific TODO
|
||||||
|
item bullet. CHARACTER is the fallback character used in
|
||||||
|
terminal displays, where composing characters cannot be relied
|
||||||
|
upon. See also ‘org-superstar-leading-fallback’.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(alist :key-type (string :format "TODO keyword: %v")
|
||||||
|
:value-type
|
||||||
|
(choice
|
||||||
|
(character :value ?◉
|
||||||
|
:format "Bullet character: %v\n"
|
||||||
|
:tag "Simple bullet character")
|
||||||
|
(list :tag "Advanced string and fallback"
|
||||||
|
(string :value "◉"
|
||||||
|
:format "String of characters to compose: %v")
|
||||||
|
(character :value ?◉
|
||||||
|
:format "Fallback character for terminal: %v\n")))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(put 'org-superstar-leading-bullet
|
||||||
|
'safe-local-variable
|
||||||
|
#'char-or-string-p)
|
||||||
|
|
||||||
|
(defun org-superstar--set-lbullet (symbol value)
|
||||||
|
"Set SYMBOL ‘org-superstar-leading-bullet’ to VALUE.
|
||||||
|
If set to a character, also set ‘org-superstar-leading-fallback’."
|
||||||
|
(set-default symbol value)
|
||||||
|
(when (characterp value)
|
||||||
|
(set-default 'org-superstar-leading-fallback value)))
|
||||||
|
|
||||||
|
(defcustom org-superstar-leading-bullet " ․"
|
||||||
|
"A special bullet used for leading stars.
|
||||||
|
Normally, this variable is a character replacing the default
|
||||||
|
stars. If it’s a string, list, or vector, compose the
|
||||||
|
replacement according to the rules of ‘compose-region’ for the
|
||||||
|
COMPONENTS argument.
|
||||||
|
|
||||||
|
If ‘org-hide-leading-stars’ is nil, leading stars in a headline
|
||||||
|
are represented as a sequence of this bullet using the face
|
||||||
|
‘org-superstar-leading’. Otherwise, this variable has no effect and
|
||||||
|
‘org-mode’ covers leading stars using ‘org-hide’.
|
||||||
|
|
||||||
|
This variable is only used for graphical displays.
|
||||||
|
‘org-superstar-leading-fallback’ is used for terminal displays
|
||||||
|
instead.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(choice
|
||||||
|
(character :tag "Single character to display"
|
||||||
|
:format "\n%t: %v\n"
|
||||||
|
:value ?‥)
|
||||||
|
(string :tag "String of characters to compose replacement from"
|
||||||
|
:format "\n%t:\n%v"
|
||||||
|
:value " ․")
|
||||||
|
(vector :tag "Vector of chars and composition rules"
|
||||||
|
(repeat
|
||||||
|
:inline t
|
||||||
|
:tag "Composition sequence"
|
||||||
|
(list :inline t :tag "Composition pair"
|
||||||
|
(character :tag "alt char" :value ?\s)
|
||||||
|
(sexp :tag "rule"))))
|
||||||
|
(repeat
|
||||||
|
:tag "Sequence of chars and composition rules"
|
||||||
|
(list :inline t :tag "Composition pair"
|
||||||
|
(character :tag "alt char" :value ?\s)
|
||||||
|
(sexp :tag "rule"))))
|
||||||
|
:risky t
|
||||||
|
:set #'org-superstar--set-lbullet)
|
||||||
|
|
||||||
|
(defcustom org-superstar-leading-fallback
|
||||||
|
(cond ((characterp org-superstar-leading-bullet)
|
||||||
|
org-superstar-leading-bullet)
|
||||||
|
(t ?‥))
|
||||||
|
"A special bullet used for leading stars.
|
||||||
|
This variable is a character replacing the default stars in
|
||||||
|
terminal displays instead of ‘org-superstar-leading-bullet’.
|
||||||
|
|
||||||
|
If the leading bullet is set to a character before the package is
|
||||||
|
loaded, this variable’s default value is set to that character as
|
||||||
|
well. Setting the leading bullet to a character using the custom
|
||||||
|
interface also automatically sets this variable.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(character :tag "Single character to display"
|
||||||
|
:format "\n%t: %v\n"
|
||||||
|
:value ?‥))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Other Custom Variables
|
||||||
|
|
||||||
|
(defcustom org-superstar-cycle-headline-bullets t
|
||||||
|
"Non-nil means cycle through all available headline bullets.
|
||||||
|
|
||||||
|
The following values are meaningful:
|
||||||
|
|
||||||
|
An integer value of N cycles through the first N entries of the
|
||||||
|
list instead of the whole list.
|
||||||
|
|
||||||
|
If otherwise non-nil, cycle through the entirety of the list.
|
||||||
|
This is the default behavior inherited from org-bullets.
|
||||||
|
|
||||||
|
If nil, repeat the final list entry for all successive levels.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(choice
|
||||||
|
(const :tag "Cycle through the whole list." t)
|
||||||
|
(const :tag "Repeat the last element indefinitely." nil)
|
||||||
|
(integer :tag "Repeat the first <integer> elements only."
|
||||||
|
:format "Repeat the first %v entries exclusively.\n"
|
||||||
|
:size 8
|
||||||
|
:value 1
|
||||||
|
:validate org-superstar--validate-hcycle)))
|
||||||
|
|
||||||
|
(defun org-superstar--validate-hcycle (text-field)
|
||||||
|
"Raise an error if TEXT-FIELD’s value is an invalid hbullet number.
|
||||||
|
This function is used for ‘org-superstar-cycle-headline-bullets’.
|
||||||
|
If the integer exceeds the length of
|
||||||
|
‘org-superstar-headline-bullets-list’, set it to the length and
|
||||||
|
raise an error."
|
||||||
|
(let ((ncycle (widget-value text-field))
|
||||||
|
(maxcycle (org-superstar--hbullets-length)))
|
||||||
|
(unless (<= 1 ncycle maxcycle)
|
||||||
|
(widget-put
|
||||||
|
text-field
|
||||||
|
:error (format "Value must be between 1 and %i"
|
||||||
|
maxcycle))
|
||||||
|
(widget-value-set text-field maxcycle)
|
||||||
|
text-field)))
|
||||||
|
|
||||||
|
(defcustom org-superstar-prettify-item-bullets t
|
||||||
|
"Non-nil means display plain lists bullets as UTF8 bullets.
|
||||||
|
|
||||||
|
Each type of plain list bullet is associated with a
|
||||||
|
corresponding UTF8 character in ‘org-superstar-item-bullet-alist’.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type '(choice (const :tag "Enable item bullet fontification" t)
|
||||||
|
(const :tag "Disable item bullet fontification" nil)))
|
||||||
|
|
||||||
|
(defcustom org-superstar-special-todo-items nil
|
||||||
|
"Non-nil means use special bullets for TODO items.
|
||||||
|
|
||||||
|
Instead of displaying bullets corresponding to TODO items
|
||||||
|
according to ‘org-superstar-headline-bullets-list’ (dependent on
|
||||||
|
the headline’s level), display a bullet according to
|
||||||
|
‘org-superstar-todo-bullet-alist’ (dependent on the TODO
|
||||||
|
keyword)."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
(defvar-local org-superstar-lightweight-lists nil
|
||||||
|
"Non-nil means circumvent expensive calls to ‘org-superstar-plain-list-p’.
|
||||||
|
|
||||||
|
There is usually no need to use this variable directly; instead,
|
||||||
|
use the command ‘org-superstar-toggle-lightweight-lists’.")
|
||||||
|
|
||||||
|
|
||||||
|
;;; Faces
|
||||||
|
|
||||||
|
(defface org-superstar-leading
|
||||||
|
'((default . (:inherit default :foreground "gray")))
|
||||||
|
"Face used to display prettified leading stars in a headline."
|
||||||
|
:group 'org-superstar)
|
||||||
|
;; REVIEW: I read that it's generally discouraged to :inherit while
|
||||||
|
;; overriding certain properties. Does that also apply to inheriting
|
||||||
|
;; default?
|
||||||
|
|
||||||
|
(defface org-superstar-header-bullet
|
||||||
|
'((default . nil))
|
||||||
|
"Face containing distinguishing features headline bullets.
|
||||||
|
This face is applied to header bullets \"on top of\" existing
|
||||||
|
fontification provided by org, allowing you to inherit the
|
||||||
|
default look of a heading line while still being able to make
|
||||||
|
modifications. Every specified face property will replace those
|
||||||
|
currently in place. Consequently, leaving all face properties
|
||||||
|
unspecified inherits the org-level-X faces for header bullets."
|
||||||
|
:group 'org-superstar)
|
||||||
|
|
||||||
|
(defface org-superstar-item
|
||||||
|
'((default . (:inherit default)))
|
||||||
|
"Face used to display prettified item bullets."
|
||||||
|
:group 'org-superstar)
|
||||||
|
|
||||||
|
(defcustom org-superstar-remove-leading-stars nil
|
||||||
|
"Non-nil means font-lock should hide leading star characters.
|
||||||
|
|
||||||
|
A more radical version of ‘org-hide-leading-stars’, where the
|
||||||
|
indentation caused by leading stars is completely removed. It
|
||||||
|
works similar to ‘org-hide-emphasis-markers’.
|
||||||
|
|
||||||
|
If Non-nil, this variable takes precedence over
|
||||||
|
‘org-hide-leading-stars’.
|
||||||
|
|
||||||
|
This variable only eliminates indentation caused directly by
|
||||||
|
leading stars, meaning additional indentation should be
|
||||||
|
preserved. For an example of this, see the minor-mode command
|
||||||
|
‘org-indent-mode’.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
:group 'org-superstar
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
|
||||||
|
;;; Functions intended for users
|
||||||
|
|
||||||
|
(defun org-superstar-configure-like-org-bullets ()
|
||||||
|
"Configure Superstar mode to approximate ‘org-bullets-mode’.
|
||||||
|
This function automatically sets various custom variables, and
|
||||||
|
therefore should only be called *once* per session, before any
|
||||||
|
other manual customization of this package.
|
||||||
|
|
||||||
|
Warning: This function sets a variable outside of this package:
|
||||||
|
‘org-hide-leading-stars’.
|
||||||
|
|
||||||
|
This function is only meant as a small convenience for people who
|
||||||
|
just want minor departures from ‘org-bullets-mode’. For a more
|
||||||
|
fine-grained customization, it’s better to just set the variables
|
||||||
|
you want.
|
||||||
|
|
||||||
|
This changes the following variables:
|
||||||
|
‘org-superstar-cycle-headline-bullets’: Enabled.
|
||||||
|
‘org-hide-leading-stars’: Enabled.
|
||||||
|
‘org-superstar-special-todo-items’: Disabled.
|
||||||
|
|
||||||
|
You should call ‘org-superstar-restart’ after changing this
|
||||||
|
variable for your changes to take effect."
|
||||||
|
(setq org-superstar-cycle-headline-bullets t)
|
||||||
|
(setq org-hide-leading-stars t)
|
||||||
|
(setq org-superstar-special-todo-items nil)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun org-superstar-toggle-lightweight-lists ()
|
||||||
|
"Toggle syntax checking for plain list items.
|
||||||
|
|
||||||
|
Disabling syntax checking will cause Org Superstar to display
|
||||||
|
lines looking like plain lists (for example in code) like plain
|
||||||
|
lists. However, this may cause significant speedup for org files
|
||||||
|
containing several hundred list items."
|
||||||
|
(interactive)
|
||||||
|
(setq org-superstar-lightweight-lists
|
||||||
|
(not org-superstar-lightweight-lists)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Accessor Functions
|
||||||
|
|
||||||
|
(defun org-superstar--get-todo (pom)
|
||||||
|
"Return the TODO keyword at point or marker POM.
|
||||||
|
If no TODO property is found, return nil."
|
||||||
|
(save-match-data
|
||||||
|
(let ((todo-property
|
||||||
|
(cdar (org-entry-properties pom "TODO"))))
|
||||||
|
(when (stringp todo-property)
|
||||||
|
todo-property))))
|
||||||
|
|
||||||
|
(defun org-superstar--todo-bullet ()
|
||||||
|
"Return the desired TODO item bullet, if defined.
|
||||||
|
If no entry can be found in ‘org-superstar-todo-bullet-alist’ for
|
||||||
|
the current keyword, return nil."
|
||||||
|
(let* ((todo-kw
|
||||||
|
(org-superstar--get-todo (match-beginning 0)))
|
||||||
|
(todo-bullet
|
||||||
|
(assoc-string todo-kw
|
||||||
|
org-superstar-todo-bullet-alist))
|
||||||
|
(todo-bullet (cdr todo-bullet))
|
||||||
|
(todo-fallback nil))
|
||||||
|
(cond
|
||||||
|
((characterp todo-bullet)
|
||||||
|
todo-bullet)
|
||||||
|
((listp todo-bullet)
|
||||||
|
(setq todo-fallback (cadr todo-bullet))
|
||||||
|
(setq todo-bullet (car todo-bullet))
|
||||||
|
(if (org-superstar-graphic-p)
|
||||||
|
todo-bullet
|
||||||
|
todo-fallback)))))
|
||||||
|
|
||||||
|
(defun org-superstar--hbullets-length ()
|
||||||
|
"Return the length of ‘org-superstar-headline-bullets-list’."
|
||||||
|
(length org-superstar-headline-bullets-list))
|
||||||
|
|
||||||
|
(defun org-superstar--hbullet (level)
|
||||||
|
"Return the desired headline bullet replacement for LEVEL N.
|
||||||
|
|
||||||
|
If the headline is also a TODO item, you can override the usually
|
||||||
|
displayed bullet depending on the TODO keyword by setting
|
||||||
|
‘org-superstar-special-todo-items’ to t and adding relevant
|
||||||
|
TODO keyword entries to ‘org-superstar-todo-bullet-alist’.
|
||||||
|
|
||||||
|
See also ‘org-superstar-cycle-headline-bullets’."
|
||||||
|
(let ((max-bullets org-superstar-cycle-headline-bullets)
|
||||||
|
(n (if org-odd-levels-only (/ (1- level) 2) (1- level)))
|
||||||
|
(todo-bullet (when org-superstar-special-todo-items
|
||||||
|
(org-superstar--todo-bullet))))
|
||||||
|
(cond (todo-bullet)
|
||||||
|
((integerp max-bullets)
|
||||||
|
(string-to-char
|
||||||
|
(elt org-superstar-headline-bullets-list
|
||||||
|
(% n max-bullets))))
|
||||||
|
(max-bullets
|
||||||
|
(string-to-char
|
||||||
|
(elt org-superstar-headline-bullets-list
|
||||||
|
(% n (org-superstar--hbullets-length)))))
|
||||||
|
(t
|
||||||
|
(string-to-char
|
||||||
|
(elt org-superstar-headline-bullets-list
|
||||||
|
(min n (1- (org-superstar--hbullets-length)))))))))
|
||||||
|
|
||||||
|
(defun org-superstar--ibullet (bullet-string)
|
||||||
|
"Return BULLET-STRINGs desired UTF-8 replacement.
|
||||||
|
|
||||||
|
Each of the three regular plain list bullets +, - and * will be
|
||||||
|
replaced by their corresponding entry in ‘org-superstar-item-bullet-alist’."
|
||||||
|
(or (cdr (assq (string-to-char bullet-string)
|
||||||
|
org-superstar-item-bullet-alist))
|
||||||
|
(string-to-char bullet-string)))
|
||||||
|
|
||||||
|
(defun org-superstar--lbullet ()
|
||||||
|
"Return the correct leading bullet for the current display."
|
||||||
|
(if (org-superstar-graphic-p)
|
||||||
|
org-superstar-leading-bullet
|
||||||
|
org-superstar-leading-fallback))
|
||||||
|
|
||||||
|
(defun org-superstar--heading-level ()
|
||||||
|
"Return the heading level of the currently matched headline."
|
||||||
|
(- (match-end 0) (match-beginning 0) 1))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Predicates
|
||||||
|
;; ‘org-list-in-valid-context-p’ is currently not working.
|
||||||
|
|
||||||
|
;; Explicitly returning t is redundant, but does not leak information
|
||||||
|
;; about how the predicate is implemented.
|
||||||
|
(defun org-superstar-plain-list-p ()
|
||||||
|
"Return t if the current match is a proper plain list.
|
||||||
|
|
||||||
|
This function may be expensive for files with very large plain
|
||||||
|
lists; consider using ‘org-superstar-toggle-lightweight-lists’ in
|
||||||
|
such cases to avoid slowdown."
|
||||||
|
(or org-superstar-lightweight-lists
|
||||||
|
(and (save-match-data
|
||||||
|
(org-element-lineage (org-element-at-point)
|
||||||
|
'(plain-list) t))
|
||||||
|
t)))
|
||||||
|
|
||||||
|
(defun org-superstar-headline-or-inlinetask-p ()
|
||||||
|
"Return t if the current match is a proper headline or inlinetask."
|
||||||
|
(save-match-data
|
||||||
|
(and (org-at-heading-p) t)))
|
||||||
|
|
||||||
|
(defun org-superstar-headline-p ()
|
||||||
|
"Return t if the current match is a proper headline."
|
||||||
|
(save-match-data
|
||||||
|
(org-with-limited-levels
|
||||||
|
(and (org-at-heading-p) t))))
|
||||||
|
|
||||||
|
(defun org-superstar-inlinetask-p ()
|
||||||
|
"Return t if the current match is a proper inlinetask."
|
||||||
|
(and (featurep 'org-inlinetask)
|
||||||
|
(org-superstar-headline-or-inlinetask-p)
|
||||||
|
(not (org-superstar-headline-p))))
|
||||||
|
|
||||||
|
(defun org-superstar-graphic-p ()
|
||||||
|
"Return t if the current display supports proper composing."
|
||||||
|
(display-graphic-p))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Fontification
|
||||||
|
|
||||||
|
(defun org-superstar--prettify-ibullets ()
|
||||||
|
"Prettify plain list bullets.
|
||||||
|
|
||||||
|
This function uses ‘org-superstar-plain-list-p’ to avoid
|
||||||
|
prettifying bullets in (for example) source blocks."
|
||||||
|
(when (org-superstar-plain-list-p)
|
||||||
|
(let* ((current-bullet (match-string 1)))
|
||||||
|
(compose-region (match-beginning 1)
|
||||||
|
(match-end 1)
|
||||||
|
(org-superstar--ibullet current-bullet)))
|
||||||
|
'org-superstar-item))
|
||||||
|
|
||||||
|
(defun org-superstar--unprettify-ibullets ()
|
||||||
|
"Revert visual tweaks made to item bullets in current buffer."
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (re-search-forward "^[ \t]+\\([-+*]\\) " nil t)
|
||||||
|
(decompose-region (match-beginning 1) (match-end 1)))))
|
||||||
|
|
||||||
|
(defun org-superstar--prettify-main-hbullet ()
|
||||||
|
"Prettify the trailing star in a headline.
|
||||||
|
|
||||||
|
This function uses ‘org-superstar-headline-or-inlinetask-p’ to avoid
|
||||||
|
prettifying bullets in (for example) source blocks."
|
||||||
|
(when (org-superstar-headline-or-inlinetask-p)
|
||||||
|
(let ((level (org-superstar--heading-level)))
|
||||||
|
(compose-region (match-beginning 1) (match-end 1)
|
||||||
|
(org-superstar--hbullet level))))
|
||||||
|
'org-superstar-header-bullet)
|
||||||
|
|
||||||
|
(defun org-superstar--prettify-other-hbullet ()
|
||||||
|
"Prettify the second last star in a headline.
|
||||||
|
This is only done if the particular title’s level is part of an
|
||||||
|
inline task, see ‘org-inlinetask-min-level’.
|
||||||
|
|
||||||
|
This function uses ‘org-superstar-inlinetask-p’ to avoid
|
||||||
|
prettifying bullets in (for example) source blocks."
|
||||||
|
(when (org-superstar-inlinetask-p)
|
||||||
|
(let ((level (org-superstar--heading-level)))
|
||||||
|
(compose-region (match-beginning 2) (match-end 2)
|
||||||
|
(org-superstar--hbullet level))
|
||||||
|
'org-superstar-header-bullet)))
|
||||||
|
|
||||||
|
(defun org-superstar--prettify-other-lbullet ()
|
||||||
|
"Prettify the first leading bullet after the headline bullet.
|
||||||
|
This function serves as an extension of
|
||||||
|
‘org-superstar--prettify-leading-hbullets’.
|
||||||
|
This function uses ‘org-superstar-headline-p’ to avoid
|
||||||
|
prettifying bullets in (for example) source blocks."
|
||||||
|
(cond ((org-superstar-headline-p)
|
||||||
|
'org-superstar-leading)
|
||||||
|
((org-superstar-inlinetask-p)
|
||||||
|
'org-inlinetask)))
|
||||||
|
|
||||||
|
(defun org-superstar--prettify-leading-hbullets ()
|
||||||
|
"Prettify the leading bullets of a header line.
|
||||||
|
Unless ‘org-hide-leading-stars’ is non-nil, each leading star is
|
||||||
|
visually replaced by ‘org-superstar-leading-bullet’ and inherits
|
||||||
|
face properties from ‘org-superstar-leading’.
|
||||||
|
|
||||||
|
If viewed from a terminal, ‘org-superstar-leading-fallback’ is
|
||||||
|
used instead of the regular leading bullet to avoid errors.
|
||||||
|
|
||||||
|
This function uses ‘org-superstar-headline-or-inlinetask-p’ to avoid
|
||||||
|
prettifying bullets in (for example) source blocks."
|
||||||
|
(when (org-superstar-headline-or-inlinetask-p)
|
||||||
|
(let ((star-beg (match-beginning 3))
|
||||||
|
(lead-end (if (org-superstar-headline-p)
|
||||||
|
(match-end 2) (match-end 3))))
|
||||||
|
(while (< star-beg lead-end)
|
||||||
|
(compose-region star-beg (setq star-beg (1+ star-beg))
|
||||||
|
(org-superstar--lbullet)))
|
||||||
|
'org-superstar-leading)))
|
||||||
|
|
||||||
|
(defun org-superstar--make-invisible (subexp)
|
||||||
|
"Make part of the text matched by the last search invisible.
|
||||||
|
SUBEXP, a number, specifies which parenthesized expression in the
|
||||||
|
last regexp. If there is no SUBEXPth pair, do nothing."
|
||||||
|
;; REVIEW: Do you think when-let would be nicer here?
|
||||||
|
(let ((start (match-beginning subexp))
|
||||||
|
(end (match-end subexp)))
|
||||||
|
(when start
|
||||||
|
(add-text-properties
|
||||||
|
start end '(invisible org-superstar-hide)))))
|
||||||
|
|
||||||
|
(defun org-superstar--unprettify-hbullets ()
|
||||||
|
"Revert visual tweaks made to header bullets in current buffer."
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (re-search-forward "^\\*+ " nil t)
|
||||||
|
(decompose-region (match-beginning 0) (match-end 0)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Font Lock
|
||||||
|
|
||||||
|
(defvar-local org-superstar--font-lock-keywords nil)
|
||||||
|
|
||||||
|
(defun org-superstar--update-font-lock-keywords ()
|
||||||
|
"Set ‘org-superstar--font-lock-keywords’ to reflect current settings.
|
||||||
|
You should not call this function to avoid confusing this mode’s
|
||||||
|
cleanup routines."
|
||||||
|
;; The below regex is nicked from ‘org-list-full-item-re’, but
|
||||||
|
;; reduced to only match simple lists. Changes were made to enforce
|
||||||
|
;; a leading space before asterisks to avoid confusion with title
|
||||||
|
;; bullets.
|
||||||
|
(setq org-superstar--font-lock-keywords
|
||||||
|
`(,@(when org-superstar-prettify-item-bullets
|
||||||
|
'(("^[ \t]*?\\(?:\\(?1:[-+]\\)\\|[ \t]\\(?1:\\*\\)\\) "
|
||||||
|
(1 (org-superstar--prettify-ibullets)))))
|
||||||
|
("^\\(?3:\\**?\\)\\(?2:\\*?\\)\\(?1:\\*\\) "
|
||||||
|
(1 (org-superstar--prettify-main-hbullet) prepend)
|
||||||
|
,@(unless (or org-hide-leading-stars
|
||||||
|
org-superstar-remove-leading-stars)
|
||||||
|
'((3 (org-superstar--prettify-leading-hbullets)
|
||||||
|
t)
|
||||||
|
(2 (org-superstar--prettify-other-lbullet)
|
||||||
|
t)))
|
||||||
|
,@(when org-superstar-remove-leading-stars
|
||||||
|
'((3 (org-superstar--make-invisible 3))
|
||||||
|
(2 (org-superstar--make-invisible 2))))
|
||||||
|
,@(when (featurep 'org-inlinetask)
|
||||||
|
'((2 (org-superstar--prettify-other-hbullet)
|
||||||
|
prepend)))
|
||||||
|
;; If requested, put another function here that formats the
|
||||||
|
;; first star of an inlinetask as a bullet.
|
||||||
|
))))
|
||||||
|
|
||||||
|
(defun org-superstar--fontify-buffer ()
|
||||||
|
"Fontify the buffer."
|
||||||
|
(when font-lock-mode
|
||||||
|
(save-restriction
|
||||||
|
(widen)
|
||||||
|
(font-lock-ensure)
|
||||||
|
(font-lock-flush))))
|
||||||
|
|
||||||
|
;;; Mode commands
|
||||||
|
;;;###autoload
|
||||||
|
(define-minor-mode org-superstar-mode
|
||||||
|
"Use UTF8 bullets for headlines and plain lists."
|
||||||
|
nil nil nil
|
||||||
|
:group 'org-superstar
|
||||||
|
:require 'org
|
||||||
|
(cond
|
||||||
|
;; Bail if Org is not enabled.
|
||||||
|
((and org-superstar-mode
|
||||||
|
(not (derived-mode-p 'org-mode)))
|
||||||
|
(message "Org mode is not enabled in this buffer.")
|
||||||
|
(org-superstar-mode 0))
|
||||||
|
;; Set up Superstar.
|
||||||
|
(org-superstar-mode
|
||||||
|
(font-lock-remove-keywords nil org-superstar--font-lock-keywords)
|
||||||
|
(org-superstar--update-font-lock-keywords)
|
||||||
|
(font-lock-add-keywords nil org-superstar--font-lock-keywords
|
||||||
|
'append)
|
||||||
|
(org-superstar--fontify-buffer)
|
||||||
|
(add-to-invisibility-spec '(org-superstar-hide)))
|
||||||
|
;; Clean up nd exit.
|
||||||
|
(t
|
||||||
|
(remove-from-invisibility-spec '(org-superstar-hide))
|
||||||
|
(font-lock-remove-keywords nil org-superstar--font-lock-keywords)
|
||||||
|
(setq org-superstar--font-lock-keywords
|
||||||
|
(default-value 'org-superstar--font-lock-keywords))
|
||||||
|
(org-superstar--unprettify-ibullets)
|
||||||
|
(org-superstar--unprettify-hbullets)
|
||||||
|
(org-superstar--fontify-buffer))))
|
||||||
|
|
||||||
|
(defun org-superstar-restart ()
|
||||||
|
"Re-enable Org Superstar mode, if the mode is enabled."
|
||||||
|
(interactive)
|
||||||
|
(when org-superstar-mode
|
||||||
|
(org-superstar-mode 0)
|
||||||
|
(org-superstar-mode 1)))
|
||||||
|
|
||||||
|
|
||||||
|
(provide 'org-superstar)
|
||||||
|
;;; org-superstar.el ends here
|
||||||
225
lisp/org-table-sticky-header.el
Normal file
225
lisp/org-table-sticky-header.el
Normal file
@@ -0,0 +1,225 @@
|
|||||||
|
;;; org-table-sticky-header.el --- Sticky header for org-mode tables -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2017 Junpeng Qiu
|
||||||
|
|
||||||
|
;; Author: Junpeng Qiu <qjpchmail@gmail.com>
|
||||||
|
;; Keywords: extensions
|
||||||
|
;; Package-Version: 20190924.506
|
||||||
|
;; Package-Commit: b65442857128ab04724aaa301e60aa874a31a798
|
||||||
|
;; Version: 0.1.0
|
||||||
|
;; Package-Requires: ((org "8.2.10") (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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; ______________________________
|
||||||
|
|
||||||
|
;; ORG-TABLE-STIKCY-HEADER-MODE
|
||||||
|
|
||||||
|
;; Junpeng Qiu
|
||||||
|
;; ______________________________
|
||||||
|
|
||||||
|
|
||||||
|
;; Table of Contents
|
||||||
|
;; _________________
|
||||||
|
|
||||||
|
;; 1 Overview
|
||||||
|
;; 2 Usage
|
||||||
|
;; 3 Demo
|
||||||
|
|
||||||
|
|
||||||
|
;; [[file:https://melpa.org/packages/org-table-sticky-header-badge.svg]]
|
||||||
|
|
||||||
|
;; A minor mode to show the sticky header for org-mode tables.
|
||||||
|
|
||||||
|
|
||||||
|
;; [[file:https://melpa.org/packages/org-table-sticky-header-badge.svg]]
|
||||||
|
;; https://melpa.org/#/org-table-sticky-header
|
||||||
|
|
||||||
|
|
||||||
|
;; 1 Overview
|
||||||
|
;; ==========
|
||||||
|
|
||||||
|
;; Similar to `semantic-stickyfunc-mode', this package uses the header
|
||||||
|
;; line to show the table header when it is out of sight.
|
||||||
|
|
||||||
|
|
||||||
|
;; 2 Usage
|
||||||
|
;; =======
|
||||||
|
|
||||||
|
;; To install manually:
|
||||||
|
;; ,----
|
||||||
|
;; | (add-to-list 'load-path "/path/to/org-table-sticky-header.el")
|
||||||
|
;; `----
|
||||||
|
|
||||||
|
;; `M-x org-table-sticky-header-mode' to enable the minor mode in an
|
||||||
|
;; org-mode buffer.
|
||||||
|
|
||||||
|
;; To automatically enable the minor mode in all org-mode buffers, use
|
||||||
|
;; ,----
|
||||||
|
;; | (add-hook 'org-mode-hook 'org-table-sticky-header-mode)
|
||||||
|
;; `----
|
||||||
|
|
||||||
|
|
||||||
|
;; 3 Demo
|
||||||
|
;; ======
|
||||||
|
|
||||||
|
;; [./screenshots/demo.gif]
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'org)
|
||||||
|
(require 'org-table)
|
||||||
|
|
||||||
|
(defface org-table-sticky-header-face
|
||||||
|
'((t :inherit 'default))
|
||||||
|
"Face for org-table-sticky-header."
|
||||||
|
:group 'org-faces)
|
||||||
|
|
||||||
|
(defvar org-table-sticky-header--last-win-start -1)
|
||||||
|
(defvar org-table-sticky-header--old-header-line-format nil)
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--is-header-p (line)
|
||||||
|
(not
|
||||||
|
(or (string-match "^ *|-" line)
|
||||||
|
(let ((cells (split-string line "|"))
|
||||||
|
(ret t))
|
||||||
|
(catch 'break
|
||||||
|
(dolist (c cells ret)
|
||||||
|
(unless (or (string-match "^ *$" c)
|
||||||
|
(string-match "^ *<[0-9]+> *$" c)
|
||||||
|
(string-match "^ *<[rcl][0-9]*> *$" c))
|
||||||
|
(throw 'break nil))))))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--table-real-begin ()
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (org-table-begin))
|
||||||
|
(while (and (not (eobp))
|
||||||
|
(not (org-table-sticky-header--is-header-p
|
||||||
|
(buffer-substring-no-properties
|
||||||
|
(point-at-bol)
|
||||||
|
(point-at-eol)))))
|
||||||
|
(forward-line))
|
||||||
|
(point)))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header-org-table-header-visible-p ()
|
||||||
|
(save-excursion
|
||||||
|
(goto-char org-table-sticky-header--last-win-start)
|
||||||
|
(>= (org-table-sticky-header--table-real-begin) (point))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--get-display-line-number-width ()
|
||||||
|
(if (bound-and-true-p display-line-numbers-mode)
|
||||||
|
;; 2 extra columns for padding
|
||||||
|
(+ 2 (line-number-display-width))
|
||||||
|
0))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--get-line-prefix-width (line)
|
||||||
|
(let (prefix)
|
||||||
|
(or (and (bound-and-true-p org-indent-mode)
|
||||||
|
(setq prefix (get-text-property 0 'line-prefix line))
|
||||||
|
(string-width prefix))
|
||||||
|
0)))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--get-visual-header (text visual-col)
|
||||||
|
(if (= visual-col 0)
|
||||||
|
text
|
||||||
|
(with-temp-buffer
|
||||||
|
(insert text)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (> visual-col 0)
|
||||||
|
(when (string= (get-text-property (point) 'display) "=>")
|
||||||
|
(setq visual-col (1- visual-col)))
|
||||||
|
(move-point-visually 1)
|
||||||
|
(setq visual-col (1- visual-col)))
|
||||||
|
(buffer-substring (point) (point-at-eol)))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header-get-org-table-header ()
|
||||||
|
(let ((col (window-hscroll))
|
||||||
|
visual-header)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char org-table-sticky-header--last-win-start)
|
||||||
|
(if (bobp)
|
||||||
|
""
|
||||||
|
(if (org-at-table-p 'any)
|
||||||
|
(goto-char (org-table-sticky-header--table-real-begin))
|
||||||
|
(forward-line -1))
|
||||||
|
(setq visual-header
|
||||||
|
(org-table-sticky-header--get-visual-header
|
||||||
|
(buffer-substring (point-at-bol) (point-at-eol))
|
||||||
|
col))
|
||||||
|
(remove-text-properties 0
|
||||||
|
(length visual-header)
|
||||||
|
'(face nil)
|
||||||
|
visual-header)
|
||||||
|
visual-header))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--fetch-header ()
|
||||||
|
(if (org-table-sticky-header-org-table-header-visible-p)
|
||||||
|
(setq header-line-format org-table-sticky-header--old-header-line-format)
|
||||||
|
;; stole from `semantic-stickyfunc-mode'
|
||||||
|
(let ((line (org-table-sticky-header-get-org-table-header)))
|
||||||
|
(setq header-line-format
|
||||||
|
`(:eval (list
|
||||||
|
(propertize
|
||||||
|
" "
|
||||||
|
'display
|
||||||
|
'((space :align-to
|
||||||
|
,(+ (org-table-sticky-header--get-display-line-number-width)
|
||||||
|
(org-table-sticky-header--get-line-prefix-width line)))))
|
||||||
|
(propertize
|
||||||
|
,line
|
||||||
|
'face 'org-table-sticky-header-face)))))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--scroll-function (win start-pos)
|
||||||
|
(unless (= org-table-sticky-header--last-win-start start-pos)
|
||||||
|
(setq org-table-sticky-header--last-win-start start-pos)
|
||||||
|
(save-match-data
|
||||||
|
(org-table-sticky-header--fetch-header))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--insert-delete-column ()
|
||||||
|
(if org-table-sticky-header-mode
|
||||||
|
(save-match-data
|
||||||
|
(org-table-sticky-header--fetch-header))))
|
||||||
|
|
||||||
|
(defun org-table-sticky-header--table-move-column (&optional left)
|
||||||
|
(if org-table-sticky-header-mode
|
||||||
|
(save-match-data
|
||||||
|
(org-table-sticky-header--fetch-header))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(define-minor-mode org-table-sticky-header-mode
|
||||||
|
"Sticky header for org-mode tables."
|
||||||
|
nil " OTSH" nil
|
||||||
|
(if org-table-sticky-header-mode
|
||||||
|
(if (derived-mode-p 'org-mode)
|
||||||
|
(progn
|
||||||
|
(setq org-table-sticky-header--old-header-line-format header-line-format)
|
||||||
|
(add-hook 'window-scroll-functions
|
||||||
|
'org-table-sticky-header--scroll-function 'append 'local)
|
||||||
|
(advice-add 'org-table-delete-column :after #'org-table-sticky-header--insert-delete-column)
|
||||||
|
(advice-add 'org-table-insert-column :after #'org-table-sticky-header--insert-delete-column)
|
||||||
|
(advice-add 'org-table-move-column :after #'org-table-sticky-header--table-move-column)
|
||||||
|
(setq org-table-sticky-header--last-win-start (window-start))
|
||||||
|
(org-table-sticky-header--fetch-header))
|
||||||
|
(setq org-table-sticky-header-mode nil)
|
||||||
|
(error "Not in `org-mode'"))
|
||||||
|
(advice-remove 'org-table-delete-column #'org-table-sticky-header--insert-delete-column)
|
||||||
|
(advice-remove 'org-table-insert-column #'org-table-sticky-header--insert-delete-column)
|
||||||
|
(advice-remove 'org-table-move-column #'org-table-sticky-header--table-move-column)
|
||||||
|
(remove-hook 'window-scroll-functions 'org-table-sticky-header--scroll-function 'local)
|
||||||
|
(setq header-line-format org-table-sticky-header--old-header-line-format)))
|
||||||
|
|
||||||
|
(provide 'org-table-sticky-header)
|
||||||
|
;;; org-table-sticky-header.el ends here
|
||||||
445
lisp/orgit.el
Normal file
445
lisp/orgit.el
Normal file
@@ -0,0 +1,445 @@
|
|||||||
|
;;; orgit.el --- support for Org links to Magit buffers -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2014-2020 The Magit Project Contributors
|
||||||
|
|
||||||
|
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||||
|
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
|
||||||
|
|
||||||
|
;; Package-Requires: ((emacs "25.1") (magit "2.90.1") (org "9.3"))
|
||||||
|
;; Package-Version: 20200621.2143
|
||||||
|
;; Package-Commit: a4e689f009a19edf5475ec20f6d723b2ab375db6
|
||||||
|
;; Homepage: https://github.com/magit/orgit
|
||||||
|
|
||||||
|
;; This library 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 library 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 library. If not, see http://www.gnu.org/licenses.
|
||||||
|
|
||||||
|
;; This library was inspired by `org-magit.el' which was written by
|
||||||
|
;; Yann Hodique <yann.hodique@gmail.com> and is distributed under the
|
||||||
|
;; GNU General Public License version 2 or later.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; This package defines the Org link types `orgit', `orgit-rev', and
|
||||||
|
;; `orgit-log', which can be used to link to Magit status, revision,
|
||||||
|
;; and log buffers.
|
||||||
|
|
||||||
|
;; Use the command `org-store-link' in such a buffer to store a link.
|
||||||
|
;; Later you can insert that into an Org buffer using the command
|
||||||
|
;; `org-insert-link'.
|
||||||
|
|
||||||
|
;; Alternatively you can use `org-insert-link' to insert a link
|
||||||
|
;; without first storing it. When prompted, first enter just the
|
||||||
|
;; link type followed by a colon and press RET. Then you are
|
||||||
|
;; prompted again and can provide the repository with completion.
|
||||||
|
;; The `orgit-rev' and `orgit-log' types additionally read a revision,
|
||||||
|
;; again with completion.
|
||||||
|
|
||||||
|
;; Format
|
||||||
|
;; ------
|
||||||
|
|
||||||
|
;; The three link types defined here take these forms:
|
||||||
|
;;
|
||||||
|
;; orgit:/path/to/repo/ links to a `magit-status' buffer
|
||||||
|
;; orgit-rev:/path/to/repo/::REV links to a `magit-revision' buffer
|
||||||
|
;; orgit-log:/path/to/repo/::ARGS links to a `magit-log' buffer
|
||||||
|
|
||||||
|
;; Before v1.3.0 only the first revision was stored in `orgit-log'
|
||||||
|
;; links, and all other revisions were discarded. All other arguments
|
||||||
|
;; were also discarded and Magit's usual mechanism for determining the
|
||||||
|
;; switches and options was used instead.
|
||||||
|
|
||||||
|
;; For backward compatibility, and because it is the common case and
|
||||||
|
;; looks best, ARGS by default has the form REV as before. However if
|
||||||
|
;; linking to a log buffer that shows the log for multiple revisions,
|
||||||
|
;; then ("REV"...) is used instead. If `orgit-log-save-arguments' is
|
||||||
|
;; non-nil, then (("REV"...) ("ARG"...) [("FILE"...)]) is always used,
|
||||||
|
;; which allows restoring the buffer most faithfully.
|
||||||
|
|
||||||
|
;; Export
|
||||||
|
;; ------
|
||||||
|
|
||||||
|
;; When an Org file containing such links is exported, then the url of
|
||||||
|
;; the remote configured with `orgit-remote' is used to generate a web
|
||||||
|
;; url according to `orgit-export-alist'. That webpage should present
|
||||||
|
;; approximately the same information as the Magit buffer would.
|
||||||
|
|
||||||
|
;; Both the remote to be considered the public remote, as well as the
|
||||||
|
;; actual web urls can be defined in individual repositories using Git
|
||||||
|
;; variables.
|
||||||
|
|
||||||
|
;; To use a remote different from `orgit-remote' but still use
|
||||||
|
;; `orgit-export-alist' to generate the web urls, use:
|
||||||
|
;;
|
||||||
|
;; git config orgit.remote REMOTE-NAME
|
||||||
|
|
||||||
|
;; To explicitly define the web urls, use something like:
|
||||||
|
;;
|
||||||
|
;; git config orgit.status http://example.com/repo/overview
|
||||||
|
;; git config orgit.rev http://example.com/repo/revision/%r
|
||||||
|
;; git config orgit.log http://example.com/repo/history/%r
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'format-spec)
|
||||||
|
(require 'magit)
|
||||||
|
(require 'org)
|
||||||
|
|
||||||
|
(unless (fboundp 'org-link-store-props)
|
||||||
|
(defalias 'org-link-store-props 'org-store-link-props))
|
||||||
|
|
||||||
|
(eval-when-compile
|
||||||
|
(require 'subr-x))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-link-set-parameters (type &rest parameters)
|
||||||
|
(if (fboundp 'org-link-set-parameters) ; since v9.0
|
||||||
|
(apply #'org-link-set-parameters type parameters)
|
||||||
|
(with-no-warnings
|
||||||
|
(org-add-link-type type
|
||||||
|
(plist-get parameters :follow)
|
||||||
|
(plist-get parameters :export))
|
||||||
|
(add-hook 'org-store-link-functions
|
||||||
|
(plist-get parameters :store)))))
|
||||||
|
|
||||||
|
;;; Options
|
||||||
|
|
||||||
|
(defgroup orgit nil
|
||||||
|
"Org links to Magit buffers."
|
||||||
|
:group 'magit-extensions
|
||||||
|
:group 'org-link)
|
||||||
|
|
||||||
|
(defcustom orgit-export-alist
|
||||||
|
`(("github.com[:/]\\(.+?\\)\\(?:\\.git\\)?$"
|
||||||
|
"https://github.com/%n"
|
||||||
|
"https://github.com/%n/commits/%r"
|
||||||
|
"https://github.com/%n/commit/%r")
|
||||||
|
("gitlab.com[:/]\\(.+?\\)\\(?:\\.git\\)?$"
|
||||||
|
"https://gitlab.com/%n"
|
||||||
|
"https://gitlab.com/%n/commits/%r"
|
||||||
|
"https://gitlab.com/%n/commit/%r")
|
||||||
|
("bitbucket.org[:/]\\(.+?\\)\\(?:\\.git\\)?$"
|
||||||
|
"https://bitbucket.org/%n"
|
||||||
|
"https://bitbucket.org/%n/commits/branch/%r"
|
||||||
|
"https://bitbucket.org/%n/commits/%r")
|
||||||
|
("code.orgmode.org[:/]\\(.+\\)$"
|
||||||
|
"https://code.orgmode.org/cgit.cgi/%n"
|
||||||
|
"https://code.orgmode.org/cgit.cgi/%n/commits/%r"
|
||||||
|
"https://code.orgmode.org/cgit.cgi/%n/commit/%r")
|
||||||
|
("git.kernel.org/pub/scm[:/]\\(.+\\)$"
|
||||||
|
"https://git.kernel.org/cgit/%n"
|
||||||
|
"https://git.kernel.org/cgit/%n/log/?h=%r"
|
||||||
|
"https://git.kernel.org/cgit/%n/commit/?id=%r"))
|
||||||
|
"Alist used to translate Git urls to web urls when exporting links.
|
||||||
|
|
||||||
|
Each entry has the form (REMOTE-REGEXP STATUS LOG REVISION). If
|
||||||
|
a REMOTE-REGEXP matches the url of the chosen remote then one of
|
||||||
|
the corresponding format strings STATUS, LOG or REVISION is used
|
||||||
|
according to the major mode of the buffer being linked to.
|
||||||
|
|
||||||
|
The first submatch of REMOTE-REGEXP has to match the repository
|
||||||
|
identifier (which usually consists of the username and repository
|
||||||
|
name). The %n in the format string is replaced with that match.
|
||||||
|
LOG and REVISION additionally have to contain %r which is
|
||||||
|
replaced with the appropriate revision.
|
||||||
|
|
||||||
|
This can be overwritten in individual repositories using the Git
|
||||||
|
variables `orgit.status', `orgit.log' and `orgit.commit'. The
|
||||||
|
values of these variables must not contain %n, but in case of the
|
||||||
|
latter two variables they must contain %r. When these variables
|
||||||
|
are defined then `orgit-remote' and `orgit.remote' have no effect."
|
||||||
|
:group 'orgit
|
||||||
|
:type '(repeat (list :tag "Remote template"
|
||||||
|
(regexp :tag "Remote regexp")
|
||||||
|
(string :tag "Status format")
|
||||||
|
(string :tag "Log format" :format "%{%t%}: %v")
|
||||||
|
(string :tag "Revision format"))))
|
||||||
|
|
||||||
|
(defcustom orgit-remote "origin"
|
||||||
|
"Default remote used when exporting links.
|
||||||
|
|
||||||
|
If there exists but one remote, then that is used unconditionally.
|
||||||
|
Otherwise if the Git variable `orgit.remote' is defined and that
|
||||||
|
remote exists, then that is used. Finally the value of this
|
||||||
|
variable is used, provided it does exist in the given repository.
|
||||||
|
If all of the above fails then `orgit-export' raises an error."
|
||||||
|
:group 'orgit
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
(defcustom orgit-log-save-arguments nil
|
||||||
|
"Whether `orgit-log' links store arguments beside the revisions."
|
||||||
|
:group 'orgit
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
(defcustom orgit-store-repository-id nil
|
||||||
|
"Whether to store only name of repository instead of path.
|
||||||
|
|
||||||
|
If nil, then store the full path to the repository in the link.
|
||||||
|
|
||||||
|
If t, then attempt to store only the name of the repository.
|
||||||
|
This works by looking up the repository's path in the list of
|
||||||
|
repositories defined by `magit-repository-directories'. If the
|
||||||
|
repository cannot be found there, then the path is used instead.
|
||||||
|
If the repository is checked out multiple times, then the names
|
||||||
|
of the clones are made unique by adding additional parts of the
|
||||||
|
path.
|
||||||
|
|
||||||
|
Storing just the name can be useful if you want to share links
|
||||||
|
with others, but be aware that doing so does not guarantee that
|
||||||
|
others will be able to open these links. The repository has to
|
||||||
|
be checked out under the same name that you use and it has to be
|
||||||
|
configured in `magit-repository-directory'."
|
||||||
|
:package-version '(orgit . "1.6.0")
|
||||||
|
:group 'orgit
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
(defcustom orgit-store-reference nil
|
||||||
|
"Whether `orgit-rev-store' attempts to store link to a reference.
|
||||||
|
|
||||||
|
If nil, then store a link to the commit itself, using its full
|
||||||
|
hash.
|
||||||
|
|
||||||
|
If t, then attempt to store a link to a tag or branch. If that
|
||||||
|
is not possible because no such reference points at the commit,
|
||||||
|
then store a link to the commit itself."
|
||||||
|
:package-version '(orgit . "1.6.0")
|
||||||
|
:group 'orgit
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
;;; Command
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(eval-after-load 'magit
|
||||||
|
'(define-key magit-mode-map [remap org-store-link] 'orgit-store-link))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-store-link (_arg)
|
||||||
|
"Like `org-store-link' but store links to all selected commits, if any."
|
||||||
|
(interactive "P")
|
||||||
|
(if-let ((sections (magit-region-sections 'commit)))
|
||||||
|
(save-excursion
|
||||||
|
(dolist (section sections)
|
||||||
|
(goto-char (oref section start))
|
||||||
|
(set-mark (point))
|
||||||
|
(activate-mark)
|
||||||
|
(call-interactively 'org-store-link))
|
||||||
|
(deactivate-mark))
|
||||||
|
(call-interactively 'org-store-link)))
|
||||||
|
|
||||||
|
;;; Status
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(eval-after-load 'org
|
||||||
|
'(orgit-link-set-parameters "orgit"
|
||||||
|
:store 'orgit-status-store
|
||||||
|
:follow 'orgit-status-open
|
||||||
|
:export 'orgit-status-export
|
||||||
|
:complete 'orgit-status-complete-link))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-status-store ()
|
||||||
|
"Store a link to a Magit-Status mode buffer.
|
||||||
|
When the region selects one or more commits, then do nothing.
|
||||||
|
In that case `orgit-rev-store' stores one or more links instead."
|
||||||
|
(when (and (eq major-mode 'magit-status-mode)
|
||||||
|
(not (magit-region-sections '(commit issue pullreq))))
|
||||||
|
(let ((repo (orgit--current-repository)))
|
||||||
|
(org-link-store-props
|
||||||
|
:type "orgit"
|
||||||
|
:link (format "orgit:%s" repo)
|
||||||
|
:description (format "%s (magit-status)" repo)))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-status-open (repo)
|
||||||
|
(magit-status-setup-buffer (orgit--repository-directory repo)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-status-export (path desc format)
|
||||||
|
(orgit-export path desc format "status" 1))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-status-complete-link (&optional arg)
|
||||||
|
(concat "orgit:" (abbreviate-file-name (magit-read-repository arg))))
|
||||||
|
|
||||||
|
;;; Log
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(eval-after-load 'org
|
||||||
|
'(orgit-link-set-parameters "orgit-log"
|
||||||
|
:store 'orgit-log-store
|
||||||
|
:follow 'orgit-log-open
|
||||||
|
:export 'orgit-log-export
|
||||||
|
:complete 'orgit-log-complete-link))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-log-store ()
|
||||||
|
"Store a link to a Magit-Log mode buffer.
|
||||||
|
When the region selects one or more commits, then do nothing.
|
||||||
|
In that case `orgit-rev-store' stores one or more links instead."
|
||||||
|
(when (and (eq major-mode 'magit-log-mode)
|
||||||
|
(not (magit-region-sections 'commit)))
|
||||||
|
(let ((repo (orgit--current-repository))
|
||||||
|
(args (if orgit-log-save-arguments
|
||||||
|
(if magit-buffer-log-files
|
||||||
|
(list magit-buffer-revisions
|
||||||
|
magit-buffer-log-args
|
||||||
|
magit-buffer-log-files)
|
||||||
|
(list magit-buffer-revisions
|
||||||
|
magit-buffer-log-args))
|
||||||
|
magit-buffer-revisions)))
|
||||||
|
(org-link-store-props
|
||||||
|
:type "orgit-log"
|
||||||
|
:link (format "orgit-log:%s::%S" repo args)
|
||||||
|
:description (format "%s %S" repo (cons 'magit-log args))))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-log-open (path)
|
||||||
|
(pcase-let* ((`(,repo ,args) (split-string path "::"))
|
||||||
|
(default-directory (orgit--repository-directory repo))
|
||||||
|
(`(,revs ,args ,files)
|
||||||
|
(cond ((string-prefix-p "((" args)
|
||||||
|
(read args))
|
||||||
|
((string-prefix-p "(" args)
|
||||||
|
(list (read args) (car (magit-log-arguments))))
|
||||||
|
(t
|
||||||
|
(list (list args) (car (magit-log-arguments)))))))
|
||||||
|
(magit-log-setup-buffer revs args files)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-log-export (path desc format)
|
||||||
|
(orgit-export path desc format "log" 2))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-log-complete-link (&optional arg)
|
||||||
|
(let ((default-directory (magit-read-repository arg)))
|
||||||
|
(format "orgit-log:%s::%s"
|
||||||
|
(abbreviate-file-name default-directory)
|
||||||
|
(magit-read-branch-or-commit "Revision"))))
|
||||||
|
|
||||||
|
;;; Revision
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(eval-after-load 'org
|
||||||
|
'(orgit-link-set-parameters "orgit-rev"
|
||||||
|
:store 'orgit-rev-store
|
||||||
|
:follow 'orgit-rev-open
|
||||||
|
:export 'orgit-rev-export
|
||||||
|
:complete 'orgit-rev-complete-link))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-rev-store ()
|
||||||
|
"Store a link to a Magit-Revision mode buffer.
|
||||||
|
With a prefix argument instead store the name of a tag or branch
|
||||||
|
that points at the revision, if any.
|
||||||
|
|
||||||
|
If `orgit-store-reference' is non-nil, then the meaning of the
|
||||||
|
prefix argument is reversed.
|
||||||
|
|
||||||
|
When the region selects one or more commits, e.g. in a log, then
|
||||||
|
store links to the Magit-Revision mode buffers for these commits."
|
||||||
|
(cond ((eq major-mode 'magit-revision-mode)
|
||||||
|
(orgit-rev-store-1 magit-buffer-revision))
|
||||||
|
((derived-mode-p 'magit-mode)
|
||||||
|
(when-let ((revs (magit-region-values 'commit)))
|
||||||
|
(mapc 'orgit-rev-store-1 revs)
|
||||||
|
t))))
|
||||||
|
|
||||||
|
(defun orgit-rev-store-1 (rev)
|
||||||
|
(let ((repo (orgit--current-repository))
|
||||||
|
(ref (and (if orgit-store-reference
|
||||||
|
(not current-prefix-arg)
|
||||||
|
current-prefix-arg)
|
||||||
|
(or (and (magit-ref-p rev) rev)
|
||||||
|
(magit-name-tag rev)
|
||||||
|
(magit-name-branch rev)))))
|
||||||
|
(org-link-store-props
|
||||||
|
:type "orgit-rev"
|
||||||
|
:link (format "orgit-rev:%s::%s" repo
|
||||||
|
(or ref (magit-rev-parse rev)))
|
||||||
|
:description (format "%s (magit-rev %s)" repo
|
||||||
|
(or ref (magit-rev-abbrev rev))))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-rev-open (path)
|
||||||
|
(pcase-let* ((`(,repo ,rev) (split-string path "::"))
|
||||||
|
(default-directory (orgit--repository-directory repo)))
|
||||||
|
(magit-revision-setup-buffer
|
||||||
|
rev (car (magit-diff-arguments 'magit-revision-mode)) nil)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-rev-export (path desc format)
|
||||||
|
(orgit-export path desc format "rev" 3))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun orgit-rev-complete-link (&optional arg)
|
||||||
|
(let ((default-directory (magit-read-repository arg)))
|
||||||
|
(format "orgit-rev:%s::%s"
|
||||||
|
(abbreviate-file-name default-directory)
|
||||||
|
(magit-read-branch-or-commit "Revision"))))
|
||||||
|
|
||||||
|
;;; Export
|
||||||
|
|
||||||
|
(defun orgit-export (path desc format gitvar idx)
|
||||||
|
(pcase-let*
|
||||||
|
((`(,dir ,rev) (split-string path "::"))
|
||||||
|
(default-directory (file-name-as-directory (expand-file-name dir)))
|
||||||
|
(remotes (magit-git-lines "remote"))
|
||||||
|
(remote (magit-get "orgit.remote"))
|
||||||
|
(remote (cond ((= (length remotes) 1) (car remotes))
|
||||||
|
((member remote remotes) remote)
|
||||||
|
((member orgit-remote remotes) orgit-remote))))
|
||||||
|
(if remote
|
||||||
|
(if-let ((link (or (when-let ((url (magit-get "orgit" gitvar)))
|
||||||
|
(format-spec url `((?r . ,rev))))
|
||||||
|
(when-let ((url (magit-get "remote" remote "url"))
|
||||||
|
(format (cl-find-if
|
||||||
|
(lambda (elt)
|
||||||
|
(string-match (car elt) url))
|
||||||
|
orgit-export-alist)))
|
||||||
|
(format-spec (nth idx format)
|
||||||
|
`((?n . ,(match-string 1 url))
|
||||||
|
(?r . ,rev)))))))
|
||||||
|
(orgit--format-export link desc format)
|
||||||
|
(error "Cannot determine public url for %s" path))
|
||||||
|
(error "Cannot determine public remote for %s" default-directory))))
|
||||||
|
|
||||||
|
(defun orgit--format-export (link desc format)
|
||||||
|
(pcase format
|
||||||
|
(`html (format "<a href=\"%s\">%s</a>" link desc))
|
||||||
|
(`latex (format "\\href{%s}{%s}" link desc))
|
||||||
|
(`ascii link)
|
||||||
|
(_ link)))
|
||||||
|
|
||||||
|
;;; Utilities
|
||||||
|
|
||||||
|
(defun orgit--current-repository ()
|
||||||
|
(or (and orgit-store-repository-id
|
||||||
|
(car (rassoc default-directory (magit-repos-alist))))
|
||||||
|
(abbreviate-file-name default-directory)))
|
||||||
|
|
||||||
|
(defun orgit--repository-directory (repo)
|
||||||
|
(let ((dir (or (cdr (assoc repo (magit-repos-alist)))
|
||||||
|
(file-name-as-directory (expand-file-name repo)))))
|
||||||
|
(cond ((file-exists-p dir) dir)
|
||||||
|
((string-match-p "\\`[./]" repo)
|
||||||
|
(error "Cannot open link; %S does not exist" dir))
|
||||||
|
(t
|
||||||
|
(error "Cannot open link; no entry for %S in `%s'"
|
||||||
|
repo 'magit-repository-directories)))))
|
||||||
|
|
||||||
|
;;; _
|
||||||
|
(provide 'orgit)
|
||||||
|
;; Local Variables:
|
||||||
|
;; indent-tabs-mode: nil
|
||||||
|
;; End:
|
||||||
|
;;; orgit.el ends here
|
||||||
686
lisp/ov.el
Normal file
686
lisp/ov.el
Normal file
@@ -0,0 +1,686 @@
|
|||||||
|
;;; ov.el --- Overlay library for Emacs Lisp -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2014 by Shingo Fukuyama
|
||||||
|
|
||||||
|
;; Version: 1.0.6
|
||||||
|
;; Package-Version: 20200326.1042
|
||||||
|
;; Package-Commit: c5b9aa4e1b00d702eb2caedd61c69a22a5fa1fab
|
||||||
|
;; Author: Shingo Fukuyama - http://fukuyama.co
|
||||||
|
;; URL: https://github.com/ShingoFukuyama/ov.el
|
||||||
|
;; Created: Mar 20 2014
|
||||||
|
;; Keywords: convenience overlay
|
||||||
|
;; Package-Requires: ((emacs "24.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 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.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Simple way to manipulate overlay for Emacs.
|
||||||
|
;; More information is in README.md or https://github.com/ShingoFukuyama/ov.el
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
|
||||||
|
(defgroup ov nil
|
||||||
|
"Group for ov.el"
|
||||||
|
:prefix "ov-" :group 'development)
|
||||||
|
|
||||||
|
(defvar ov-sticky-front nil)
|
||||||
|
(defvar ov-sticky-rear nil)
|
||||||
|
|
||||||
|
;; http://www.gnu.org/software/emacs/manual/html_node/elisp/Overlay-Properties.html
|
||||||
|
(defvar ov-prop-list '(priority
|
||||||
|
window
|
||||||
|
category
|
||||||
|
face
|
||||||
|
mouse-face
|
||||||
|
display
|
||||||
|
help-echo
|
||||||
|
field
|
||||||
|
modification-hooks
|
||||||
|
insert-in-front-hooks
|
||||||
|
insert-behind-hooks
|
||||||
|
invisible
|
||||||
|
intangible
|
||||||
|
isearch-open-invisible
|
||||||
|
isearch-open-invisible-temporary
|
||||||
|
before-string
|
||||||
|
after-string
|
||||||
|
line-prefix
|
||||||
|
wrap-prefix
|
||||||
|
evaporate
|
||||||
|
local-map
|
||||||
|
keymap))
|
||||||
|
|
||||||
|
;; Make overlay / Set properties -----------------------------------------------
|
||||||
|
;; Just make an overlay from `beg' and `end'.
|
||||||
|
;; Alias ;; Argument
|
||||||
|
(defalias 'ov-create 'make-overlay) ;; (beg end)
|
||||||
|
(defalias 'ov-make 'make-overlay) ;; (beg end)
|
||||||
|
|
||||||
|
(defun ov (beg end &rest properties)
|
||||||
|
"Make an overlay from BEG to END.
|
||||||
|
|
||||||
|
If PROPERTIES are specified, set them for the created overlay."
|
||||||
|
(if properties
|
||||||
|
(progn
|
||||||
|
;; To pass properties to `ov-set'
|
||||||
|
(when (listp (car-safe properties))
|
||||||
|
(setq properties (car properties)))
|
||||||
|
(let ((o (ov-make beg end nil (not ov-sticky-front) ov-sticky-rear)))
|
||||||
|
(ov-set o properties)
|
||||||
|
o))
|
||||||
|
(ov-make beg end nil (not ov-sticky-front) ov-sticky-rear)))
|
||||||
|
|
||||||
|
(defun ov-line (&optional point)
|
||||||
|
"Make an overlay from the beginning of the line to the beginning of the next line, which include POINT."
|
||||||
|
(let (o)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (or point (point)))
|
||||||
|
(setq o (ov-make (point-at-bol) (min (1+ (point-at-eol)) (point-max))
|
||||||
|
nil (not ov-sticky-front) ov-sticky-rear)))
|
||||||
|
o))
|
||||||
|
|
||||||
|
(defun ov-match (string &optional beg end)
|
||||||
|
"Make overlays spanning the regions that match STRING.
|
||||||
|
|
||||||
|
If BEG and END are numbers, they specify the bounds of the search."
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (or beg (point-min)))
|
||||||
|
(let (ov-or-ovs)
|
||||||
|
(ov-recenter (point-max))
|
||||||
|
(while (search-forward string end t)
|
||||||
|
(setq ov-or-ovs (cons (ov-make (match-beginning 0)
|
||||||
|
(match-end 0)
|
||||||
|
nil (not ov-sticky-front) ov-sticky-rear)
|
||||||
|
ov-or-ovs)))
|
||||||
|
ov-or-ovs)))
|
||||||
|
|
||||||
|
(defun ov-regexp (regexp &optional beg end)
|
||||||
|
"Make overlays spanning the regions that match REGEXP.
|
||||||
|
|
||||||
|
If BEG and END are numbers, they specify the bounds of the search."
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (or beg (point-min)))
|
||||||
|
(let (ov-or-ovs finish)
|
||||||
|
(ov-recenter (point-max))
|
||||||
|
(while (and (not finish) (re-search-forward regexp end t))
|
||||||
|
(setq ov-or-ovs (cons (ov-make (match-beginning 0)
|
||||||
|
(match-end 0)
|
||||||
|
nil (not ov-sticky-front) ov-sticky-rear)
|
||||||
|
ov-or-ovs))
|
||||||
|
(when (= (match-beginning 0) (match-end 0))
|
||||||
|
(if (eobp)
|
||||||
|
(setq finish t)
|
||||||
|
(forward-char 1))))
|
||||||
|
ov-or-ovs)))
|
||||||
|
|
||||||
|
(defun ov-region ()
|
||||||
|
"Make an overlay from a region if region is active."
|
||||||
|
(if (use-region-p)
|
||||||
|
(let ((o (ov-make (region-beginning) (region-end)
|
||||||
|
nil (not ov-sticky-front) ov-sticky-rear)))
|
||||||
|
(deactivate-mark t)
|
||||||
|
o)
|
||||||
|
(error "Need to make region")))
|
||||||
|
|
||||||
|
(defun ov-set (ov-or-ovs-or-regexp &rest properties)
|
||||||
|
"Set overlay properties and values.
|
||||||
|
OV-OR-OVS-OR-REGEXP can be an overlay, overlays or a regexp.
|
||||||
|
|
||||||
|
If an overlay or list of overlays, PROPERTIES are set for these.
|
||||||
|
|
||||||
|
If a regexp, first overlays are created on the matching
|
||||||
|
regions (see `ov-regexp'), then the properties are set."
|
||||||
|
(when ov-or-ovs-or-regexp
|
||||||
|
(unless (and ov-or-ovs-or-regexp properties)
|
||||||
|
(error "Arguments are OV and PROPERTIES"))
|
||||||
|
(when (listp (car-safe properties))
|
||||||
|
(setq properties (car properties)))
|
||||||
|
(let ((len (length properties))
|
||||||
|
(i 0)
|
||||||
|
return-type)
|
||||||
|
(cond ((stringp ov-or-ovs-or-regexp)
|
||||||
|
(setq ov-or-ovs-or-regexp (ov-regexp ov-or-ovs-or-regexp))
|
||||||
|
(setq return-type 'ov-list))
|
||||||
|
((ov-p ov-or-ovs-or-regexp)
|
||||||
|
(setq ov-or-ovs-or-regexp (cons ov-or-ovs-or-regexp nil))
|
||||||
|
(setq return-type 'ov))
|
||||||
|
((listp ov-or-ovs-or-regexp)
|
||||||
|
(setq return-type 'ov-list)))
|
||||||
|
(unless (eq (logand len 1) 0)
|
||||||
|
(error "Invalid properties pairs"))
|
||||||
|
(mapc (lambda (ov)
|
||||||
|
(while (< i len)
|
||||||
|
(overlay-put
|
||||||
|
ov
|
||||||
|
(nth i properties) (nth (setq i (1+ i)) properties))
|
||||||
|
(setq i (1+ i)))
|
||||||
|
(setq i 0))
|
||||||
|
ov-or-ovs-or-regexp)
|
||||||
|
(if (eq 'ov return-type)
|
||||||
|
(car ov-or-ovs-or-regexp)
|
||||||
|
ov-or-ovs-or-regexp))))
|
||||||
|
(defalias 'ov-put 'ov-set)
|
||||||
|
|
||||||
|
(defun ov-insert (any)
|
||||||
|
"Insert ANY (string, number, list, etc) covered with an empty overlay."
|
||||||
|
(or (stringp any) (setq any (format "%s" any)))
|
||||||
|
(let* ((beg (point))
|
||||||
|
(len (length any))
|
||||||
|
(end (+ beg len)))
|
||||||
|
(insert any)
|
||||||
|
(ov-make beg end nil (not ov-sticky-front) ov-sticky-rear)))
|
||||||
|
|
||||||
|
|
||||||
|
;; Delete overlay --------------------------------------------------------------
|
||||||
|
;;;###autoload
|
||||||
|
(cl-defun ov-clear (&optional prop-or-beg (val-or-end 'any) beg end)
|
||||||
|
"Clear overlays satisfying a condition.
|
||||||
|
|
||||||
|
If PROP-OR-BEG is a symbol, clear overlays with this property set to non-nil.
|
||||||
|
|
||||||
|
If VAL-OR-END is non-nil, the specified property's value should
|
||||||
|
`equal' to this value.
|
||||||
|
|
||||||
|
If both of these are numbers, clear the overlays between these points.
|
||||||
|
|
||||||
|
If BEG and END are numbers, clear the overlays with specified
|
||||||
|
property and value between these points.
|
||||||
|
|
||||||
|
With no arguments, clear all overlays in the buffer."
|
||||||
|
(interactive)
|
||||||
|
(cl-labels ((clear
|
||||||
|
(con beg end)
|
||||||
|
(ov-recenter (or end (point-max)))
|
||||||
|
(mapc (lambda (ov)
|
||||||
|
(when (and (memq prop-or-beg (ov-prop ov))
|
||||||
|
(if con
|
||||||
|
t (equal val-or-end (ov-val ov prop-or-beg))))
|
||||||
|
(delete-overlay ov)))
|
||||||
|
(overlays-in beg end))))
|
||||||
|
(cond
|
||||||
|
;; (ov-clear)
|
||||||
|
((and (not prop-or-beg) (eq 'any val-or-end) (not beg) (not end))
|
||||||
|
(ov-recenter (point-max))
|
||||||
|
(remove-overlays (point-min) (point-max)))
|
||||||
|
;; (ov-clear 10 500)
|
||||||
|
((and (numberp prop-or-beg) (numberp val-or-end))
|
||||||
|
(ov-recenter val-or-end)
|
||||||
|
(remove-overlays prop-or-beg val-or-end))
|
||||||
|
;; (ov-clear 'face 'warning)
|
||||||
|
((and (symbolp prop-or-beg) (not (eq 'any val-or-end)) (not beg) (not end))
|
||||||
|
(clear nil (point-min) (point-max)))
|
||||||
|
;; (ov-clear 'face) or (ov-clear 'face 'any)
|
||||||
|
((and (symbolp prop-or-beg) (eq 'any val-or-end) (not beg) (not end))
|
||||||
|
(clear t (point-min) (point-max)))
|
||||||
|
;; (ov-clear 'face 'worning 10 500)
|
||||||
|
((and (symbolp prop-or-beg) (not (eq 'any val-or-end)) (numberp beg) (numberp end))
|
||||||
|
(clear nil beg end))
|
||||||
|
;; (ov-clear 'face 'any 10 500)
|
||||||
|
((and (symbolp prop-or-beg) (eq 'any val-or-end) (numberp beg) (numberp end))
|
||||||
|
(clear t beg end))
|
||||||
|
(t nil)))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defmacro ov-reset (ov-or-ovs-variable)
|
||||||
|
"Clear overlays in OV-OR-OVS-VARIABLE.
|
||||||
|
|
||||||
|
OV-OR-OVS-VARIABLE should be a symbol whose value is an overlay
|
||||||
|
or a list of overlays.
|
||||||
|
|
||||||
|
Finally, the variable is set to nil."
|
||||||
|
`(progn
|
||||||
|
(mapc (lambda (ov)
|
||||||
|
(delete-overlay ov))
|
||||||
|
(if (listp ,ov-or-ovs-variable)
|
||||||
|
,ov-or-ovs-variable
|
||||||
|
(cons ,ov-or-ovs-variable nil)))
|
||||||
|
(setq ,ov-or-ovs-variable nil)))
|
||||||
|
|
||||||
|
|
||||||
|
;; Look up overlay parameters, etc ---------------------------------------------
|
||||||
|
;; Alias ;; Argument
|
||||||
|
;; Check whether `ov' is overlay or not.
|
||||||
|
(defalias 'ov-p 'overlayp) ;; (ov)
|
||||||
|
(defalias 'ov? 'overlayp) ;; (ov)
|
||||||
|
(defalias 'ov-val 'overlay-get) ;; (ov property)
|
||||||
|
;; Get the boundary position of an overlay.
|
||||||
|
(defalias 'ov-beg 'overlay-start) ;; (ov)
|
||||||
|
(defalias 'ov-end 'overlay-end) ;; (ov)
|
||||||
|
;; Get the buffer object of an overlay.
|
||||||
|
(defalias 'ov-buf 'overlay-buffer) ;; (ov)
|
||||||
|
;; Get the properties from an overlay.
|
||||||
|
(defalias 'ov-prop 'overlay-properties) ;; (ov)
|
||||||
|
|
||||||
|
(defun ov-length (overlay)
|
||||||
|
"Return the length of the region spanned by OVERLAY."
|
||||||
|
(- (ov-end overlay) (ov-beg overlay)))
|
||||||
|
|
||||||
|
(defun ov-spec (ov-or-ovs)
|
||||||
|
"Make an overlay specification list.
|
||||||
|
This is of the form:
|
||||||
|
|
||||||
|
(beginning end buffer &rest properties).
|
||||||
|
|
||||||
|
OV-OR-OVS should be an overlay or a list of overlays."
|
||||||
|
(or (listp ov-or-ovs) (setq ov-or-ovs (cons ov-or-ovs nil)))
|
||||||
|
(mapcar (lambda (ov)
|
||||||
|
(list (ov-beg ov) (ov-end ov)
|
||||||
|
(ov-buf ov) (overlay-properties ov)))
|
||||||
|
ov-or-ovs))
|
||||||
|
|
||||||
|
|
||||||
|
;; Get present overlay object --------------------------------------------------
|
||||||
|
(defun ov-at (&optional point)
|
||||||
|
"Get an overlay at POINT.
|
||||||
|
POINT defaults to the current `point'."
|
||||||
|
(or point (setq point (point)))
|
||||||
|
(car (overlays-at point)))
|
||||||
|
|
||||||
|
;; Get overlays between `beg' and `end'.
|
||||||
|
(cl-defun ov-in (&optional prop-or-beg (val-or-end 'any) beg end)
|
||||||
|
"Get overlays satisfying a condition.
|
||||||
|
|
||||||
|
If PROP-OR-BEG is a symbol, get overlays with this property set to non-nil.
|
||||||
|
|
||||||
|
If VAL-OR-END is non-nil, the specified property's value should
|
||||||
|
`equal' to this value.
|
||||||
|
|
||||||
|
If both of these are numbers, get the overlays between these points.
|
||||||
|
|
||||||
|
If BEG and END are numbers, get the overlays with specified
|
||||||
|
property and value between these points.
|
||||||
|
|
||||||
|
With no arguments, get all overlays in the buffer."
|
||||||
|
(cl-labels ((in (con beg end)
|
||||||
|
(delq nil
|
||||||
|
(mapcar
|
||||||
|
(lambda ($ov)
|
||||||
|
(when (and (memq prop-or-beg (ov-prop $ov))
|
||||||
|
(if con
|
||||||
|
t (equal val-or-end (ov-val $ov prop-or-beg))))
|
||||||
|
$ov))
|
||||||
|
(overlays-in beg end)))))
|
||||||
|
(cond
|
||||||
|
;; (ov-in)
|
||||||
|
((and (not prop-or-beg) (eq 'any val-or-end) (not beg) (not end))
|
||||||
|
(overlays-in (point-min) (point-max)))
|
||||||
|
;; (ov-in 10 500)
|
||||||
|
((and (numberp prop-or-beg) (numberp val-or-end))
|
||||||
|
(overlays-in prop-or-beg val-or-end))
|
||||||
|
;; (ov-in 'face 'warning)
|
||||||
|
((and (symbolp prop-or-beg) (not (eq 'any val-or-end)) (not beg) (not end))
|
||||||
|
(in nil (point-min) (point-max)))
|
||||||
|
;; (ov-in 'face) or (ov-in 'face 'any)
|
||||||
|
((and (symbolp prop-or-beg) (eq 'any val-or-end) (not beg) (not end))
|
||||||
|
(in t (point-min) (point-max)))
|
||||||
|
;; (ov-in 'face 'worning 10 500)
|
||||||
|
((and (symbolp prop-or-beg) (not (eq 'any val-or-end)) (numberp beg) (numberp end))
|
||||||
|
(in nil beg end))
|
||||||
|
;; (ov-in 'face 'any 10 500)
|
||||||
|
((and (symbolp prop-or-beg) (eq 'any val-or-end) (numberp beg) (numberp end))
|
||||||
|
(in t beg end))
|
||||||
|
(t nil))))
|
||||||
|
|
||||||
|
(defun ov-all ()
|
||||||
|
"Get all the overlays in the entire buffer."
|
||||||
|
(overlays-in (point-min) (point-max)))
|
||||||
|
|
||||||
|
(defun ov-backwards (&optional point)
|
||||||
|
"Get all the overlays from the beginning of the buffer to POINT."
|
||||||
|
(ov-in (point-min) (or point (point))))
|
||||||
|
|
||||||
|
(defun ov-forwards (&optional point)
|
||||||
|
"Get all the overlays from POINT to the end of the buffer."
|
||||||
|
(ov-in (or point (point)) (point-max)))
|
||||||
|
|
||||||
|
|
||||||
|
;; Overlay manipulation --------------------------------------------------------
|
||||||
|
;; Alias ;; Argument
|
||||||
|
(defalias 'ov-recenter 'overlay-recenter) ;; (point)
|
||||||
|
;; Move an existing overlay position to another position.
|
||||||
|
(defalias 'ov-move 'move-overlay) ;; (ov beg end &optional buffer)
|
||||||
|
|
||||||
|
(defmacro ov-timeout (time func func-after)
|
||||||
|
"Execute FUNC-AFTER after TIME seconds passed since FUNC finished."
|
||||||
|
(declare (indent 1))
|
||||||
|
(if (symbolp func-after)
|
||||||
|
(run-with-timer time nil `(lambda () (funcall ',func-after)))
|
||||||
|
(run-with-timer time nil `(lambda () ,(funcall `(lambda () ,func-after)))))
|
||||||
|
(if (symbolp func)
|
||||||
|
(funcall func)
|
||||||
|
(funcall (lambda () (eval func)))))
|
||||||
|
|
||||||
|
(cl-defun ov-next (&optional point-or-prop prop-or-val (val 'any))
|
||||||
|
"Get the next overlay satisfying a condition.
|
||||||
|
|
||||||
|
If POINT-OR-PROP is a symbol, get the next overlay with this
|
||||||
|
property being non-nil.
|
||||||
|
|
||||||
|
If PROP-OR-VAL is non-nil, the property should have this value.
|
||||||
|
|
||||||
|
If POINT-OR-PROP is a number, get the next overlay after this
|
||||||
|
point.
|
||||||
|
|
||||||
|
If PROP-OR-VAL and VAL are also specified, get the next overlay
|
||||||
|
after POINT-OR-PROP having property PROP-OR-VAL set to VAL (with
|
||||||
|
VAL unspecified, only the presence of property is tested)."
|
||||||
|
(cl-labels ((next
|
||||||
|
(po pr va)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (next-overlay-change po))
|
||||||
|
(let (ov)
|
||||||
|
(while (and (not (if (setq ov (ov-at (point)))
|
||||||
|
(and (memq pr (ov-prop ov))
|
||||||
|
(if (eq 'any va)
|
||||||
|
t (equal va (ov-val ov pr))))))
|
||||||
|
(not (if (eobp) (progn (setq ov nil) t))))
|
||||||
|
(goto-char (next-overlay-change (point))))
|
||||||
|
ov))))
|
||||||
|
(cond
|
||||||
|
;; (ov-next) or (ov-next 300)
|
||||||
|
((and (or (numberp point-or-prop) (not point-or-prop))
|
||||||
|
(not prop-or-val) (eq 'any val))
|
||||||
|
(let* ((po (next-overlay-change (or point-or-prop (point))))
|
||||||
|
(ov (ov-at po)))
|
||||||
|
(if (ov? ov)
|
||||||
|
ov
|
||||||
|
(ov-at (next-overlay-change po)))))
|
||||||
|
;; (ov-next 'face)
|
||||||
|
((and point-or-prop (symbolp point-or-prop) (not prop-or-val) (eq 'any val))
|
||||||
|
(next (point) point-or-prop 'any))
|
||||||
|
;; (ov-next 'face 'warning)
|
||||||
|
((and point-or-prop (symbolp point-or-prop) prop-or-val (eq 'any val))
|
||||||
|
(next (point) point-or-prop prop-or-val))
|
||||||
|
;; (ov-next 300 'face 'warning)
|
||||||
|
((and (or (not point-or-prop) (numberp point-or-prop))
|
||||||
|
(symbolp prop-or-val) (not (eq 'any val)))
|
||||||
|
(next (or point-or-prop (point)) prop-or-val val))
|
||||||
|
;; (ov-next 300 'face)
|
||||||
|
((and (or (numberp point-or-prop) (not point-or-prop)) (symbolp prop-or-val))
|
||||||
|
(next (or point-or-prop (point)) prop-or-val val))
|
||||||
|
(t nil))))
|
||||||
|
|
||||||
|
(cl-defun ov-prev (&optional point-or-prop prop-or-val (val 'any))
|
||||||
|
"Get the previous overlay satisfying a condition.
|
||||||
|
|
||||||
|
If POINT-OR-PROP is a symbol, get the previous overlay with this
|
||||||
|
property being non-nil.
|
||||||
|
|
||||||
|
If PROP-OR-VAL is non-nil, the property should have this value.
|
||||||
|
|
||||||
|
If POINT-OR-PROP is a number, get the previous overlay after this
|
||||||
|
point.
|
||||||
|
|
||||||
|
If PROP-OR-VAL and VAL are also specified, get the previous
|
||||||
|
overlay after POINT-OR-PROP having property PROP-OR-VAL set to
|
||||||
|
VAL (with VAL unspecified, only the presence of property is
|
||||||
|
tested)."
|
||||||
|
(cl-labels ((prev
|
||||||
|
(po pr va)
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (previous-overlay-change po))
|
||||||
|
(let (ov)
|
||||||
|
(while (and (not (if (setq ov (ov-at (1- (point))))
|
||||||
|
(and (memq pr (ov-prop ov))
|
||||||
|
(if (eq 'any va)
|
||||||
|
t (equal va (ov-val ov pr))))))
|
||||||
|
(not (if (bobp) (progn (setq ov nil) t))))
|
||||||
|
(goto-char (previous-overlay-change (point))))
|
||||||
|
ov))))
|
||||||
|
(cond
|
||||||
|
((and (or (numberp point-or-prop) (not point-or-prop))
|
||||||
|
(not prop-or-val) (eq 'any val))
|
||||||
|
(let* ((po1 (previous-overlay-change (point)))
|
||||||
|
(po2 (previous-overlay-change po1))
|
||||||
|
(ov (or (ov-at po2) (ov-at (1- po2)))))
|
||||||
|
(if (ov? ov) ov)))
|
||||||
|
;; (ov-prev 'face)
|
||||||
|
((and point-or-prop (symbolp point-or-prop) (not prop-or-val) (eq 'any val))
|
||||||
|
(prev (point) point-or-prop 'any))
|
||||||
|
;; (ov-prev 'face 'warning)
|
||||||
|
((and point-or-prop (symbolp point-or-prop) prop-or-val (eq 'any val))
|
||||||
|
(prev (point) point-or-prop prop-or-val))
|
||||||
|
;; (ov-prev 300 'face 'warning)
|
||||||
|
((and (or (not point-or-prop) (numberp point-or-prop))
|
||||||
|
(symbolp prop-or-val) (not (eq 'any val)))
|
||||||
|
(prev (or point-or-prop (point)) prop-or-val val))
|
||||||
|
;; (ov-prev 300 'face)
|
||||||
|
((and (or (numberp point-or-prop) (not point-or-prop)) (symbolp prop-or-val))
|
||||||
|
(prev (or point-or-prop (point)) prop-or-val val))
|
||||||
|
(t nil))))
|
||||||
|
|
||||||
|
(cl-defun ov-goto-next (&optional point-or-prop prop-or-val (val 'any))
|
||||||
|
"Move cursor to the end of the next overlay.
|
||||||
|
The arguments are the same as for `ov-next'."
|
||||||
|
(interactive)
|
||||||
|
(let ((o (ov-next point-or-prop prop-or-val val)))
|
||||||
|
(if o (goto-char (ov-end o)))))
|
||||||
|
|
||||||
|
(cl-defun ov-goto-prev (&optional point-or-prop prop-or-val (val 'any))
|
||||||
|
"Move cursor to the beginning of previous overlay.
|
||||||
|
The arguments are the same as for `ov-prev'."
|
||||||
|
(interactive)
|
||||||
|
(let ((o (ov-prev point-or-prop prop-or-val val)))
|
||||||
|
(if o (goto-char (ov-beg o)))))
|
||||||
|
|
||||||
|
(defun ov-keymap (ov-or-ovs-or-id &rest keybinds)
|
||||||
|
"Set KEYBINDS to an overlay or a list of overlays.
|
||||||
|
|
||||||
|
If OV-OR-OVS-OR-ID is a symbol, the KEYBINDS will be enabled for
|
||||||
|
the entire buffer and the property represented by the symbol to t.
|
||||||
|
|
||||||
|
The overlay is expanded if new inputs are inserted at the
|
||||||
|
beginning or end of the buffer."
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(when (cl-evenp (length keybinds))
|
||||||
|
(while keybinds
|
||||||
|
(let* ((key (pop keybinds))
|
||||||
|
(fn (pop keybinds))
|
||||||
|
(command (cl-typecase fn
|
||||||
|
(command fn)
|
||||||
|
(cons `(lambda () (interactive) ,fn))
|
||||||
|
(t (error "Invalid function")))))
|
||||||
|
(cl-typecase key
|
||||||
|
(vector (define-key map key command))
|
||||||
|
(string (define-key map (kbd key) command))
|
||||||
|
(list (mapc (lambda (k)
|
||||||
|
(define-key map (cl-typecase k
|
||||||
|
(vector k)
|
||||||
|
(string (kbd k))) command))
|
||||||
|
key))
|
||||||
|
(t (error "Invalid key"))))))
|
||||||
|
(if (symbolp ov-or-ovs-or-id)
|
||||||
|
(let ((ov-sticky-front t)
|
||||||
|
(ov-sticky-rear t))
|
||||||
|
(ov (point-min) (point-max) 'keymap map ov-or-ovs-or-id t))
|
||||||
|
(ov-set ov-or-ovs-or-id 'keymap map))))
|
||||||
|
|
||||||
|
|
||||||
|
;; Implement pseudo read-only overlay function ---------------------------------
|
||||||
|
(defun ov-read-only (ov-or-ovs &optional insert-in-front insert-behind)
|
||||||
|
"Implement a read-only like feature for an overlay or a list of overlays.
|
||||||
|
|
||||||
|
If INSERT-IN-FRONT is non-nil, inserting in front of each overlay is prevented.
|
||||||
|
|
||||||
|
If INSERT-BEHIND is non-nil, inserting behind of each overlay is prevented.
|
||||||
|
|
||||||
|
Note that it allows modifications from out of range of a read-only overlay.
|
||||||
|
|
||||||
|
OV-OR-OVS can be an overlay or list of overlay."
|
||||||
|
(cond ((not (and insert-in-front insert-behind))
|
||||||
|
(ov-set ov-or-ovs
|
||||||
|
'modification-hooks '(ov--read-only)))
|
||||||
|
((and insert-in-front insert-behind)
|
||||||
|
(ov-set ov-or-ovs
|
||||||
|
'modification-hooks '(ov--read-only)
|
||||||
|
'insert-in-front-hooks '(ov--read-only)
|
||||||
|
'insert-behind-hooks '(ov--read-only)))
|
||||||
|
(insert-in-front
|
||||||
|
(ov-set ov-or-ovs
|
||||||
|
'modification-hooks '(ov--read-only)
|
||||||
|
'insert-in-front-hooks '(ov--read-only)))
|
||||||
|
(t ;; Should be insert-behind
|
||||||
|
(ov-set ov-or-ovs
|
||||||
|
'modification-hooks '(ov--read-only)
|
||||||
|
'insert-behind-hooks '(ov--read-only)))))
|
||||||
|
|
||||||
|
(defun ov--read-only (ov after beg end &optional _length)
|
||||||
|
(when (and (not (or after
|
||||||
|
undo-in-progress
|
||||||
|
(eq this-command 'undo)
|
||||||
|
(eq this-command 'redo)))
|
||||||
|
;; Modification within range of a text
|
||||||
|
(or (< (ov-beg ov) beg)
|
||||||
|
(> (ov-end ov) end)))
|
||||||
|
(error "Text is read-only")))
|
||||||
|
|
||||||
|
|
||||||
|
;; Special overlay -------------------------------------------------------------
|
||||||
|
(defun ov-placeholder (ov-or-ovs)
|
||||||
|
"Set a placeholder feature for an overlay or a list of overlays.
|
||||||
|
|
||||||
|
Each overlay deletes its string and overlay, when it is modified.
|
||||||
|
|
||||||
|
OV-OR-OVS can be an overlay or list of overlay."
|
||||||
|
(ov-set ov-or-ovs
|
||||||
|
'evaporate t
|
||||||
|
'modification-hooks '(ov--placeholder)
|
||||||
|
'insert-in-front-hooks '(ov--placeholder)
|
||||||
|
'insert-behind-hooks '(ov--placeholder)))
|
||||||
|
|
||||||
|
(defun ov--placeholder (ov after beg end &optional length)
|
||||||
|
(let ((inhibit-modification-hooks t))
|
||||||
|
(when (not (or undo-in-progress
|
||||||
|
(eq this-command 'undo)
|
||||||
|
(eq this-command 'redo)))
|
||||||
|
(cond ((and (not after) (eq beg end))
|
||||||
|
(delete-region (ov-beg ov) (ov-end ov)))
|
||||||
|
((and after (> length 0))
|
||||||
|
(if (ov-beg ov)
|
||||||
|
(delete-region (ov-beg ov) (ov-end ov))))))))
|
||||||
|
|
||||||
|
|
||||||
|
;; Smear background ------------------------------------------------------------
|
||||||
|
(defun ov--parse-hex-color (hex)
|
||||||
|
"Convert a HEX color code to a RGB list.
|
||||||
|
i.e.
|
||||||
|
#99ccff => (153 204 255)
|
||||||
|
#33a => (51 51 170)"
|
||||||
|
(let (result)
|
||||||
|
|
||||||
|
(when (string-match
|
||||||
|
"^\\s-*\\#\\([0-9a-fA-F]\\)\\([0-9a-fA-F]\\)\\([0-9a-fA-F]\\)\\s-*$"
|
||||||
|
hex)
|
||||||
|
(let ((m1 (match-string 1 hex))
|
||||||
|
(m2 (match-string 2 hex))
|
||||||
|
(m3 (match-string 3 hex)))
|
||||||
|
(setq result (list (read (format "#x%s%s" m1 m1))
|
||||||
|
(read (format "#x%s%s" m2 m2))
|
||||||
|
(read (format "#x%s%s" m3 m3))))))
|
||||||
|
(when (string-match
|
||||||
|
"^\\s-*\\#\\([0-9a-fA-F]\\{2\\}\\)\\([0-9a-fA-F]\\{2\\}\\)\\([0-9a-fA-F]\\{2\\}\\)\\s-*$"
|
||||||
|
hex)
|
||||||
|
(setq result (list (read (format "#x%s" (match-string 1 hex)))
|
||||||
|
(read (format "#x%s" (match-string 2 hex)))
|
||||||
|
(read (format "#x%s" (match-string 3 hex))))))
|
||||||
|
result))
|
||||||
|
|
||||||
|
(defun ov--random-color (&optional base-color range)
|
||||||
|
"Generate random color based on BASE-COLOR and RANGE.
|
||||||
|
Default background color is used when BASE-COLOR is nil."
|
||||||
|
(or range (setq range 50))
|
||||||
|
(let ((default-background-color (ignore-errors (face-attribute 'default :background))))
|
||||||
|
(or base-color
|
||||||
|
(setq base-color
|
||||||
|
(cond ((eq 'unspecified default-background-color)
|
||||||
|
"#fff")
|
||||||
|
((string-match "^#[0-9a-fA-F]\\{3,6\\}" default-background-color)
|
||||||
|
default-background-color)
|
||||||
|
((color-name-to-rgb default-background-color) ;; yellow, LightBlue, etc...
|
||||||
|
default-background-color)
|
||||||
|
(t "#fff")))))
|
||||||
|
(if (color-name-to-rgb base-color)
|
||||||
|
(let ((rgb) (hex "#"))
|
||||||
|
(mapc (lambda (x)
|
||||||
|
(setq rgb (cons (round (* x 255)) rgb)))
|
||||||
|
(color-name-to-rgb base-color))
|
||||||
|
(setq rgb (nreverse rgb))
|
||||||
|
(mapc (lambda (x)
|
||||||
|
(setq hex (concat hex (format "%02x" x))))
|
||||||
|
rgb)
|
||||||
|
(setq base-color hex)))
|
||||||
|
(let* ((rgb (ov--parse-hex-color base-color))
|
||||||
|
(half-range (/ range 2))
|
||||||
|
(fn (lambda (n)
|
||||||
|
(let* ((base (nth n rgb))
|
||||||
|
(min half-range)
|
||||||
|
(max (- 255 half-range))
|
||||||
|
result)
|
||||||
|
(if (< base min) (setq base min))
|
||||||
|
(if (> base max) (setq base max))
|
||||||
|
(setq result (+ (- (cl-random range) half-range) base))
|
||||||
|
(if (< result 0) (setq result 0))
|
||||||
|
(if (> result 255) (setq result 255))
|
||||||
|
result)))
|
||||||
|
(r (funcall fn 0))
|
||||||
|
(g (funcall fn 1))
|
||||||
|
(b (funcall fn 2)))
|
||||||
|
(format "#%02x%02x%02x" r g b)))
|
||||||
|
|
||||||
|
(defun ov-smear (regexp-or-list &optional match-end base-color color-range)
|
||||||
|
"Set background color overlays to the current buffer.
|
||||||
|
Each background color is randomly determined based on BASE-COLOR
|
||||||
|
or the default background color.
|
||||||
|
|
||||||
|
If REGEXP-OR-LIST is regexp
|
||||||
|
Set overlays between matches of a regexp.
|
||||||
|
If REGEXP-OR-LIST is list
|
||||||
|
Set overlays between point pairs in a list.
|
||||||
|
i.e. (ov-smear '((1 . 30) (30 . 90)))"
|
||||||
|
(interactive "sSplitter: ")
|
||||||
|
(ov-clear 'ov-smear)
|
||||||
|
(let (points area length (counter 0) ov-list)
|
||||||
|
(cl-typecase regexp-or-list
|
||||||
|
(string (save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (re-search-forward regexp-or-list nil t)
|
||||||
|
(setq points (cons
|
||||||
|
(if match-end
|
||||||
|
(match-end 0)
|
||||||
|
(match-beginning 0))
|
||||||
|
points))))
|
||||||
|
(setq points (nreverse points))
|
||||||
|
(setq length (length points))
|
||||||
|
(while (< counter (1- length))
|
||||||
|
(setq area (cons
|
||||||
|
(cons
|
||||||
|
(nth counter points)
|
||||||
|
(nth (1+ counter) points))
|
||||||
|
area))
|
||||||
|
(setq counter (1+ counter))))
|
||||||
|
(list (setq area regexp-or-list)))
|
||||||
|
(mapc (lambda (a)
|
||||||
|
(let ((ov (ov (car a) (cdr a))))
|
||||||
|
(ov-set ov
|
||||||
|
'face `(:background ,(ov--random-color base-color color-range))
|
||||||
|
'ov-smear t)
|
||||||
|
(setq ov-list (cons ov ov-list))))
|
||||||
|
area)
|
||||||
|
ov-list))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(provide 'ov)
|
||||||
|
;;; ov.el ends here
|
||||||
240
lisp/ox-tufte.el
Normal file
240
lisp/ox-tufte.el
Normal file
@@ -0,0 +1,240 @@
|
|||||||
|
;;; ox-tufte.el --- Tufte HTML org-mode export backend
|
||||||
|
|
||||||
|
;; Copyright (C) 2016 Matthew Lee Hinman
|
||||||
|
|
||||||
|
;; Author: M. Lee Hinman
|
||||||
|
;; Description: An org exporter for Tufte HTML
|
||||||
|
;; Keywords: org, tufte, html
|
||||||
|
;; Package-Version: 20160926.1607
|
||||||
|
;; Version: 1.0.0
|
||||||
|
;; Package-Requires: ((org "8.2") (emacs "24"))
|
||||||
|
;; URL: https://github.com/dakrone/ox-tufte
|
||||||
|
|
||||||
|
;; This file is not 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; This is an export backend for Org-mode that exports buffers to HTML that
|
||||||
|
;; is compatible with Tufte CSS - https://edwardtufte.github.io/tufte-css/ out of
|
||||||
|
;; the box (meaning no CSS modifications needed).
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'ox)
|
||||||
|
(require 'ox-html)
|
||||||
|
|
||||||
|
|
||||||
|
;;; User-Configurable Variables
|
||||||
|
|
||||||
|
(defgroup org-export-tufte nil
|
||||||
|
"Options specific to Tufte export back-end."
|
||||||
|
:tag "Org Tufte"
|
||||||
|
:group 'org-export
|
||||||
|
:version "24.4"
|
||||||
|
:package-version '(Org . "8.0"))
|
||||||
|
|
||||||
|
(defcustom org-tufte-include-footnotes-at-bottom nil
|
||||||
|
"Non-nil means to include footnotes at the bottom of the page
|
||||||
|
in addition to being included as sidenotes. Sidenotes are not
|
||||||
|
shown on very narrow screens (phones), so it may be useful to
|
||||||
|
additionally include them at the bottom."
|
||||||
|
:group 'org-export-tufte
|
||||||
|
:type 'boolean)
|
||||||
|
|
||||||
|
|
||||||
|
;;; Define Back-End
|
||||||
|
|
||||||
|
(org-export-define-derived-backend 'tufte-html 'html
|
||||||
|
:menu-entry
|
||||||
|
'(?T "Export to Tufte-HTML"
|
||||||
|
((?T "To temporary buffer"
|
||||||
|
(lambda (a s v b) (org-tufte-export-to-buffer a s v)))
|
||||||
|
(?t "To file" (lambda (a s v b) (org-tufte-export-to-file a s v)))
|
||||||
|
(?o "To file and open"
|
||||||
|
(lambda (a s v b)
|
||||||
|
(if a (org-tufte-export-to-file t s v)
|
||||||
|
(org-open-file (org-tufte-export-to-file nil s v)))))))
|
||||||
|
:translate-alist '((footnote-reference . org-tufte-footnote-reference)
|
||||||
|
(src-block . org-tufte-src-block)
|
||||||
|
(link . org-tufte-maybe-margin-note-link)
|
||||||
|
(quote-block . org-tufte-quote-block)
|
||||||
|
(verse-block . org-tufte-verse-block)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Transcode Functions
|
||||||
|
|
||||||
|
(defun org-tufte-quote-block (quote-block contents info)
|
||||||
|
"Transform a quote block into an epigraph in Tufte HTML style"
|
||||||
|
(format "<div class=\"epigraph\"><blockquote>\n%s\n%s</blockquote></div>"
|
||||||
|
contents
|
||||||
|
(if (org-element-property :name quote-block)
|
||||||
|
(format "<footer>%s</footer>"
|
||||||
|
(org-element-property :name quote-block))
|
||||||
|
"")))
|
||||||
|
|
||||||
|
(defun org-tufte-verse-block (verse-block contents info)
|
||||||
|
"Transcode a VERSE-BLOCK element from Org to HTML.
|
||||||
|
CONTENTS is verse block contents. INFO is a plist holding
|
||||||
|
contextual information."
|
||||||
|
;; Replace each newline character with line break. Also replace
|
||||||
|
;; each blank line with a line break.
|
||||||
|
(setq contents (replace-regexp-in-string
|
||||||
|
"^ *\\\\\\\\$" (format "%s\n" (org-html-close-tag "br" nil info))
|
||||||
|
(replace-regexp-in-string
|
||||||
|
"\\(\\\\\\\\\\)?[ \t]*\n"
|
||||||
|
(format "%s\n" (org-html-close-tag "br" nil info)) contents)))
|
||||||
|
;; Replace each white space at beginning of a line with a
|
||||||
|
;; non-breaking space.
|
||||||
|
(while (string-match "^[ \t]+" contents)
|
||||||
|
(let* ((num-ws (length (match-string 0 contents)))
|
||||||
|
(ws (let (out) (dotimes (i num-ws out)
|
||||||
|
(setq out (concat out " "))))))
|
||||||
|
(setq contents (replace-match ws nil t contents))))
|
||||||
|
(format "<div class=\"epigraph\"><blockquote>\n%s\n%s</blockquote></div>"
|
||||||
|
contents
|
||||||
|
(if (org-element-property :name verse-block)
|
||||||
|
(format "<footer>%s</footer>"
|
||||||
|
(org-element-property :name verse-block))
|
||||||
|
"")))
|
||||||
|
|
||||||
|
(defun org-tufte-footnote-reference (footnote-reference contents info)
|
||||||
|
"Create a footnote according to the tufte css format.
|
||||||
|
FOOTNOTE-REFERENCE is the org element, CONTENTS is nil. INFO is a
|
||||||
|
plist holding contextual information."
|
||||||
|
(format
|
||||||
|
(concat "<label for=\"%s\" class=\"margin-toggle sidenote-number\"></label>"
|
||||||
|
"<input type=\"checkbox\" id=\"%s\" class=\"margin-toggle\"/>"
|
||||||
|
"<span class=\"sidenote\">%s</span>")
|
||||||
|
(org-export-get-footnote-number footnote-reference info)
|
||||||
|
(org-export-get-footnote-number footnote-reference info)
|
||||||
|
(let ((fn-data (org-trim
|
||||||
|
(org-export-data
|
||||||
|
(org-export-get-footnote-definition footnote-reference info)
|
||||||
|
info))))
|
||||||
|
;; footnotes must have spurious <p> tags removed or they will not work
|
||||||
|
(replace-regexp-in-string "</?p.*>" "" fn-data))))
|
||||||
|
|
||||||
|
(defun org-tufte-maybe-margin-note-link (link desc info)
|
||||||
|
"Render LINK as a margin note if it starts with `mn:', for
|
||||||
|
example, `[[mn:1][this is some text]]' is margin note 1 that
|
||||||
|
will show \"this is some text\" in the margin.
|
||||||
|
|
||||||
|
If it does not, it will be passed onto the original function in
|
||||||
|
order to be handled properly. DESC is the description part of the
|
||||||
|
link. INFO is a plist holding contextual information."
|
||||||
|
(let ((path (split-string (org-element-property :path link) ":")))
|
||||||
|
(if (and (string= (org-element-property :type link) "fuzzy")
|
||||||
|
(string= (car path) "mn"))
|
||||||
|
(format
|
||||||
|
(concat "<label for=\"%s\" class=\"margin-toggle\">⊕</label>"
|
||||||
|
"<input type=\"checkbox\" id=\"%s\" class=\"margin-toggle\"/>"
|
||||||
|
"<span class=\"marginnote\">%s</span>")
|
||||||
|
(cadr path) (cadr path)
|
||||||
|
(replace-regexp-in-string "</?p.*>" "" desc))
|
||||||
|
(org-html-link link desc info))))
|
||||||
|
|
||||||
|
(defun org-tufte-src-block (src-block contents info)
|
||||||
|
"Transcode SRC-BLOCK element into Tufte HTML format. CONTENTS
|
||||||
|
is nil. INFO is a plist used as a communication channel."
|
||||||
|
(format "<pre class=\"code\"><code>%s</code></pre>"
|
||||||
|
(org-html-format-code src-block info)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Export functions
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun org-tufte-export-to-buffer (&optional async subtreep visible-only)
|
||||||
|
"Export current buffer to a Tufte HTML buffer.
|
||||||
|
|
||||||
|
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 buffer 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.
|
||||||
|
|
||||||
|
Export is done in a buffer named \"*Org Tufte Export*\", which will
|
||||||
|
be displayed when `org-export-show-temporary-export-buffer' is
|
||||||
|
non-nil."
|
||||||
|
(interactive)
|
||||||
|
(let (;; 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
|
||||||
|
"<!-- %s --><!-- %s -->")))
|
||||||
|
(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
|
||||||
|
"<!-- %s --><!-- %s -->")))
|
||||||
|
(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
|
||||||
182
lisp/page-break-lines.el
Normal file
182
lisp/page-break-lines.el
Normal file
@@ -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 <steve@sanityinc.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
677
lisp/parsebib.el
Normal file
677
lisp/parsebib.el
Normal file
@@ -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 <joostkremers@fastmail.fm>
|
||||||
|
;; Maintainer: Joost Kremers <joostkremers@fastmail.fm>
|
||||||
|
;; 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 (<abbrev> . <expansion>). 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 (<field> .
|
||||||
|
<contents>) 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
|
||||||
292
lisp/pfuture.el
Normal file
292
lisp/pfuture.el
Normal file
@@ -0,0 +1,292 @@
|
|||||||
|
;;; pfuture.el --- a simple wrapper around asynchronous processes -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2020 Alexander Miller
|
||||||
|
|
||||||
|
;; Author: Alexander Miller <alexanderm@web.de>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
763
lisp/plantuml-mode.el
Normal file
763
lisp/plantuml-mode.el
Normal file
@@ -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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
1435
lisp/popup.el
Normal file
1435
lisp/popup.el
Normal file
File diff suppressed because it is too large
Load Diff
1118
lisp/popwin.el
Normal file
1118
lisp/popwin.el
Normal file
File diff suppressed because it is too large
Load Diff
982
lisp/pos-tip.el
Normal file
982
lisp/pos-tip.el
Normal file
@@ -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
|
||||||
1386
lisp/powershell.el
Normal file
1386
lisp/powershell.el
Normal file
File diff suppressed because it is too large
Load Diff
310
lisp/pythonic.el
Normal file
310
lisp/pythonic.el
Normal file
@@ -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 <proofit404@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
1373
lisp/rainbow-mode.el
Normal file
1373
lisp/rainbow-mode.el
Normal file
File diff suppressed because it is too large
Load Diff
425
lisp/restart-emacs.el
Normal file
425
lisp/restart-emacs.el
Normal file
@@ -0,0 +1,425 @@
|
|||||||
|
;;; restart-emacs.el --- Restart emacs from within emacs -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2015-2017 Iqbal Ansari
|
||||||
|
|
||||||
|
;; Author: Iqbal Ansari <iqbalansari02@yahoo.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
747
lisp/s.el
Normal file
747
lisp/s.el
Normal file
@@ -0,0 +1,747 @@
|
|||||||
|
;;; s.el --- The long lost Emacs string manipulation library.
|
||||||
|
|
||||||
|
;; Copyright (C) 2012-2015 Magnar Sveen
|
||||||
|
|
||||||
|
;; Author: Magnar Sveen <magnars@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
455
lisp/sphinx-doc.el
Normal file
455
lisp/sphinx-doc.el
Normal file
@@ -0,0 +1,455 @@
|
|||||||
|
;;; sphinx-doc.el --- Sphinx friendly docstrings for Python functions
|
||||||
|
|
||||||
|
;; Copyright (c) 2013 <naikvin@gmail.com>
|
||||||
|
|
||||||
|
;; Author: Vineet Naik <naikvin@gmail.com>
|
||||||
|
;; 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) <http://opensource.org/licenses/MIT>
|
||||||
|
;;
|
||||||
|
;; Copyright (c) 2013 <naikvin@gmail.com>
|
||||||
|
;;
|
||||||
|
;; 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
|
||||||
|
;; <http://sphinx-doc.org/index.html>
|
||||||
|
|
||||||
|
;;; 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
|
||||||
211
lisp/stickyfunc-enhance.el
Normal file
211
lisp/stickyfunc-enhance.el
Normal file
@@ -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 <tuhdo1710@gmail.com>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
;;
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;
|
||||||
|
;;; 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:
|
||||||
1719
lisp/swiper.el
Normal file
1719
lisp/swiper.el
Normal file
File diff suppressed because it is too large
Load Diff
156
lisp/treemacs-magit.el
Normal file
156
lisp/treemacs-magit.el
Normal file
@@ -0,0 +1,156 @@
|
|||||||
|
;;; treemacs-magit.el --- Magit integration for treemacs -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2020 Alexander Miller
|
||||||
|
|
||||||
|
;; Author: Alexander Miller <alexanderm@web.de>
|
||||||
|
;; 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 <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
168
lisp/versions
Normal file
168
lisp/versions
Normal file
@@ -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 |
|
||||||
326
lisp/virtual-auto-fill.el
Normal file
326
lisp/virtual-auto-fill.el
Normal file
@@ -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 <virtual-auto-fill@luisgerhorst.de>
|
||||||
|
;; Maintainer: Luis Gerhorst <virtual-auto-fill@luisgerhorst.de>
|
||||||
|
;; 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 <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
229
lisp/visual-fill-column.el
Normal file
229
lisp/visual-fill-column.el
Normal file
@@ -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 <joostkremers@fastmail.fm>
|
||||||
|
;; Maintainer: Joost Kremers <joostkremers@fastmail.fm>
|
||||||
|
;; 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 <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; 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
|
||||||
14312
lisp/web-mode.el
Normal file
14312
lisp/web-mode.el
Normal file
File diff suppressed because it is too large
Load Diff
2758
lisp/which-key.el
Normal file
2758
lisp/which-key.el
Normal file
File diff suppressed because it is too large
Load Diff
5311
lisp/yasnippet.el
Normal file
5311
lisp/yasnippet.el
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user