diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/circe-20180525.1231/lui.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/circe-20180525.1231/lui.el | 1513 |
1 files changed, 0 insertions, 1513 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/circe-20180525.1231/lui.el b/configs/shared/emacs/.emacs.d/elpa/circe-20180525.1231/lui.el deleted file mode 100644 index 07cc758f29c0..000000000000 --- a/configs/shared/emacs/.emacs.d/elpa/circe-20180525.1231/lui.el +++ /dev/null @@ -1,1513 +0,0 @@ -;;; lui.el --- Linewise User Interface -*- lexical-binding: t -*- - -;; Copyright (C) 2005 - 2016 Jorgen Schaefer - -;; Author: Jorgen Schaefer <forcer@forcix.cx> -;; URL: https://github.com/jorgenschaefer/circe/wiki/Lui - -;; 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: - -;; Lui is a library for other Emacs Lisp programs and not useful by -;; itself. - -;; This major mode provides a user interface for applications. The -;; user interface is quite simple, consisting of an input line, a -;; prompt, and some output area, but Lui includes a lot of common -;; options, such as time stamps, filling, colorization, etc. - -;; Application programs should create modes derived from lui-mode. - -;; The application API consists of: - -;; lui-mode -;; lui-set-prompt -;; lui-insert -;; lui-input-function -;; lui-completion-function -;; lui-time-stamp-time -;; lui-time-stamp-zone -;; and the 'lui-fool and 'lui-do-not-track text properties - -;;; Code: - -(require 'button) -(require 'flyspell) -(require 'help-mode) -(require 'ispell) -(require 'paren) -(require 'ring) -(require 'thingatpt) -(require 'rx) - -(require 'tracking) - - -;;;;;;;;;;;;;;;;;;;;; -;;; Customization ;;; -;;;;;;;;;;;;;;;;;;;;; - -(defgroup lui nil - "The Linewise User Interface." - :prefix "lui-" - :group 'applications) - -(defcustom lui-scroll-behavior t - "Set the behavior lui should exhibit for scrolling. - -The following values are possible. If in doubt, use post-output. - -nil - Use default Emacs scrolling. - -post-command - Keep the input line at the end of the window if point is - after the input mark. - -post-output - Keep the input line at the end of the window only after output. - -t - Combine both post-command and post-output. - -post-scroll - Keep the input line at the end of the window on every scroll - event. Careful, this might interact badly with other functions - on `window-scroll-functions'. - - -It would be entirely sensible for Emacs to provide a setting to -do this kind of scrolling by default in a buffer. It seems rather -intuitive and sensible. But as noted on emacs-devel: - - [T]hose who know the code know that it's going to be a pain to - implement, especially if you want acceptable performance. IOW, - patches welcome - -The full discussion can be found here: - -https://lists.gnu.org/archive/html/emacs-devel/2012-10/msg00652.html - -These settings are all hacks that try to give the user the choice -between most correct behavior (post-scroll) and most compliant -behavior (post-output)." - :type '(choice (const :tag "Post Command" t) - (const :tag "Post Output" post-output) - (const :tag "Post Scroll" post-scroll) - (const :tag "Use default scrolling" nil)) - :group 'lui) -(defvaralias 'lui-scroll-to-bottom-p 'lui-scroll-behavior) - -(defcustom lui-flyspell-p nil - "Non-nil if Lui should spell-check your input. -See the function `flyspell-mode' for more information." - :type 'boolean - :group 'lui) - -(defcustom lui-flyspell-alist nil - "Alist of buffer dictionaries. - -This is a list of mappings from buffers to dictionaries to use -for the function `flyspell-mode'. The appropriate dictionary is -automatically used when Lui is activated in a buffer with a -matching buffer name. - -The entries are of the form (REGEXP DICTIONARY), where REGEXP -must match a buffer name, and DICTIONARY specifies an existing -dictionary for the function `flyspell-mode'. See -`ispell-local-dictionary-alist' and `ispell-dictionary-alist' for -a valid list of dictionaries." - :type 'string - :group 'lui) - -(defcustom lui-highlight-keywords nil - "A list of keywords to highlight. - -This specifies a list of keywords that Lui should highlight. Each -entry is of one of the following forms (similar to -`font-lock-keywords'): - - REGEXP - Highlight every match in `lui-highlight-face' - (REGEXP SUBMATCH) - Highlight the SUBMATCH (a number) in REGEXP in - `lui-highlight-face' - (REGEXP FACE) - Highlight everything matching REGEXP in FACE (a symbol) - (REGEXP SUBMATCH FACE) - Highlight the SUBMATCH in REGEXP in FACE - -In all of these cases, the FACE can also be a property list which -is then associated with the match. - -All matches are run, which means later matches can override -changes by earlier ones." - :type '(repeat (choice - (string :tag "Regular Expression") - (list :tag "Submatch" - (string :tag "Regular Expression") - (integer :tag "Submatch")) - (list :tag "Regular Expression in Specific Face" - (string :tag "Regular Expression") - (face :tag "Face")) - (list :tag "Submatch in Specific Face" - (string :tag "Regular Expression") - (integer :tag "Submatch") - (face :tag "Face")))) - :group 'lui) - -(defface lui-strong-face - '((t (:inherit bold))) - "Face used for strong markup." - :group 'lui-irc-colors) - -(defface lui-emphasis-face - '((t (:inherit italic))) - "Face for emphasis markup." - :group 'lui-irc-colors) - -(defface lui-deleted-face - '((t (:strike-through t))) - "Face for deleted messages" - :group 'lui-irc-colors) - -(defcustom lui-formatting-list nil - "List of enabled formatting types. -Each list item is a list consisting of a regular expression -matching the highlighted text, an integer for the submatch and a -face for highlighting the match." - :type `(set - (const :tag "*Strong* text" - (,(rx (or bol whitespace) - (group "*" (+? (not (any whitespace "*"))) "*") - (or eol whitespace)) - 1 lui-strong-face)) - (const :tag "_Emphasized_ text" - (,(rx (or bol whitespace) - (group "_" (+? (not (any whitespace "_"))) "_") - (or eol whitespace)) - 1 lui-emphasis-face))) - :group 'lui) - -(defcustom lui-buttons-list - `(("`\\([A-Za-z0-9+=*/-]+\\)'" 1 - lui-button-elisp-symbol 1) - ("\\<debbugs[#:]\\([0-9]+\\)" 0 - "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" 1) - ("\\<RFC ?\\([0-9]+\\)" 0 - "http://www.ietf.org/rfc/rfc%s.txt" 1) - ("\\<CVE[- ]\\([0-9]+-[0-9]+\\)" 0 - "https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-%s" 1) - ("\\<SRFI[- ]?\\([0-9]+\\)" 0 - "http://srfi.schemers.org/srfi-%s/srfi-%s.html" 1 1) - ("\\<PEP[- ]?\\([0-9]+\\)" 0 lui-button-pep 1) - ("\\<xkcd[ #]*\\([0-9]+\\)" 0 - "https://xkcd.com/%s" 1) - ("\\([0-9a-zA-Z_.-]+/[0-9a-zA-Z_.-]+\\)#\\([0-9]+\\)" 0 - "https://github.com/%s/issues/%s" 1 2)) - "The list of buttons to buttonize. -This consists of lists of four elements each: - - (REGEXP SUBMATCH FUNCTION ARG-MATCH...) - -Whenever REGEXP is found, SUBMATCH is marked as a button. When -that button is activated, FUNCTION is called with the matches -specified in ARG-MATCHES as its arguments. - -If FUNCTION is a string, it is formatted with %s replaced by -the matches in ARG-MATCHES." - :type '(repeat (list (regexp :tag "Regular expression") - (integer :tag "Submatch to buttonize") - (function :tag "Function to call for this button") - (integer :tag "Submatch to pass as an argument"))) - :group 'lui) - -(defcustom lui-button-issue-tracker nil - "A tracker URL for the current channel. - -This will cause simple #123 links to highlight as issue links to -the given repository. Use %s to insert the actual number." - :type 'string - :group 'lui) - -(defcustom lui-fill-type " " - "How Lui should fill its output. -This can be one of the following values: - - A string - This is used as the fill prefix - 'variable - The first sequence of non-whitespace characters in the - output is used as an alignment, and the rest is filled with - spaces. - A number - The first sequence of non-whitespace characters is - right-aligned at this column, and the rest is filled to - this column. - nil - Turn filling off." - :type '(choice (string :tag "Fill Prefix") - (const :tag "Variable Fill Prefix" variable) - (integer :tag "Fill Column") - (const :tag "No filling" nil)) - :group 'lui) - -(defcustom lui-fill-column 70 - "The column at which Lui should break output. -See `fill-column'." - :type 'integer - :group 'lui) - -(defcustom lui-fill-remove-face-from-newline t - "Non-nil when filling should remove faces from newlines. -Faces on a newline extend to the end of the displayed line, which -is often not was is wanted." - :type 'boolean - :group 'lui) - -(defcustom lui-time-stamp-format "[%H:%M]" - "The format of time stamps. -See `format-time-string' for a full description of available -formatting directives." - :type 'string - :group 'lui) - -(defcustom lui-time-stamp-position 'right - "Where Lui should put time-stamps. -This can be one of the following values: - - A number - At this column of the first line of output - 'right - At a column just right to `lui-fill-column' - 'left - At the left side of the output. The output is thereby moved - to the right. - 'right-margin - In the right margin. You will need to set `right-margin-width' - in all circe buffers. - 'left-margin - In the left margin. You will need to set `left-margin-width' - in all circe buffers. - nil - Do not add any time stamp." - :type '(choice (const :tag "Right" right) - (integer :tag "Column") - (const :tag "Left" left) - (const :tag "Right Margin" right-margin) - (const :tag "Left Margin" left-margin) - (const :tag "None" nil)) - :group 'lui) - -(defcustom lui-time-stamp-only-when-changed-p t - "Non-nil if Lui should only add a time stamp when the time changes. -If `lui-time-stamp-position' is 'left, this will still add the -necessary whitespace." - :type 'boolean - :group 'lui) - -(defcustom lui-read-only-output-p t - "Non-nil if Lui should make the output read-only. -Switching this off makes copying (by killing) easier for some." - :type 'boolean - :group 'lui) - -(defcustom lui-max-buffer-size 102400 - "Non-nil if Lui should truncate the buffer if it grows too much. -If the buffer size (in characters) exceeds this number, it is -truncated at the top." - :type '(choice (const :tag "Never Truncate" nil) - (integer :tag "Maximum Buffer Size")) - :group 'lui) - -(defcustom lui-input-ring-size 32 - "The size of the input history of Lui. -This is the size of the input history used by -\\[lui-previous-input] and \\[lui-next-input]." - :type 'integer - :group 'lui) - -(defcustom lui-mode-hook nil - "The hook run when Lui is started." - :type 'hook - :group 'lui) - -(defcustom lui-pre-input-hook nil - "A hook run before Lui interprets the user input. -It is called with the buffer narrowed to the input line. -Functions can modify the input if they really want to, but the -user won't see the modifications, so that's a bad idea." - :type 'hook - :group 'lui) - -(defcustom lui-pre-output-hook nil - "The hook run before output is formatted." - :type 'hook - :group 'lui) - -(defcustom lui-post-output-hook nil - "The hook run after output has been formatted." - :type 'hook - :group 'lui) - -(defface lui-time-stamp-face - '((t (:foreground "SlateBlue" :weight bold))) - "Lui mode face used for time stamps." - :group 'lui) - -(defface lui-highlight-face - ;; Taken from `font-lock-keyword-face' - '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold)) - (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold)) - (((class color) (background light)) (:foreground "Purple")) - (((class color) (background dark)) (:foreground "Cyan1")) - (t (:weight bold))) - "Lui mode face used for highlighting." - :group 'lui) - -(defface lui-button-face - '((((class color) (background light)) (:foreground "Purple" :underline t)) - (((class color) (background dark)) (:foreground "Cyan" :underline t)) - (t (:underline t))) - "Default face used for LUI buttons." - :group 'lui) - - -;;;;;;;;;;;;;;;;;;;;;;;; -;;; Client interface ;;; -;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar lui-input-function nil - "The function to be called for Lui input. -This function is called with a single argument, the input -string.") -(make-variable-buffer-local 'lui-input-function) - -(defvar lui-completion-function 'completion-at-point - "A function called to actually do completion.") - - -;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Private variables ;;; -;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar lui-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'lui-send-input) - (define-key map (kbd "TAB") 'lui-next-button-or-complete) - (define-key map (kbd "<backtab>") 'lui-previous-button) - (define-key map (kbd "<S-tab>") 'lui-previous-button) - (define-key map (kbd "M-p") 'lui-previous-input) - (define-key map (kbd "M-n") 'lui-next-input) - (define-key map (kbd "C-c C-u") 'lui-kill-to-beginning-of-line) - (define-key map (kbd "C-c C-i") 'lui-fool-toggle-display) - map) - "The key map used in Lui modes.") - -(defvar lui-input-marker nil - "The marker where input should be inserted.") -(make-variable-buffer-local 'lui-input-marker) - -(defvar lui-output-marker nil - "The marker where output should be inserted. -Use `lui-insert' instead of accessing this marker directly.") -(make-variable-buffer-local 'lui-output-marker) - -(defvar lui-input-ring nil - "The input history ring.") -(make-variable-buffer-local 'lui-input-ring) - -(defvar lui-input-ring-index nil - "The index to the current item in the input ring.") -(make-variable-buffer-local 'lui-input-ring-index) - - -;;;;;;;;;;;;;; -;;; Macros ;;; -;;;;;;;;;;;;;; - -(defmacro lui-save-undo-list (&rest body) - "Run BODY without modifying the undo list." - (let ((old-marker-sym (make-symbol "old-marker"))) - `(let ((,old-marker-sym (marker-position lui-input-marker)) - (val nil)) - ;; Don't modify the undo list. The undo list is for the user's - ;; input only. - (let ((buffer-undo-list t)) - (setq val (progn ,@body))) - (when (consp buffer-undo-list) - ;; Not t :-) - (lui-adjust-undo-list ,old-marker-sym (- lui-input-marker - ,old-marker-sym))) - val))) - - -;;;;;;;;;;;;;;;;;; -;;; Major Mode ;;; -;;;;;;;;;;;;;;;;;; - -(define-derived-mode lui-mode nil "LUI" - "The Linewise User Interface mode. -This can be used as a user interface for various applications. -Those should define derived modes of this, so this function -should never be called directly. - -It can be customized for an application by specifying a -`lui-input-function'." - (setq lui-input-marker (make-marker) - lui-output-marker (make-marker) - lui-input-ring (make-ring lui-input-ring-size) - lui-input-ring-index nil - flyspell-generic-check-word-p 'lui-flyspell-check-word-p) - (set-marker lui-input-marker (point-max)) - (set-marker lui-output-marker (point-max)) - (add-hook 'window-scroll-functions 'lui-scroll-window nil t) - (add-hook 'post-command-hook 'lui-scroll-post-command) - (add-hook 'change-major-mode-hook 'lui-change-major-mode nil t) - (lui-paren-highlighting) - (lui-time-stamp-enable-filtering) - (tracking-mode 1) - (auto-fill-mode 0) - (when (fboundp 'cursor-intangible-mode) - (cursor-intangible-mode 1)) - (when lui-flyspell-p - (require 'flyspell) - (lui-flyspell-change-dictionary))) - -(defun lui-change-major-mode () - "Assure that the user really wants to change the major mode. -This is a good value for a buffer-local `change-major-mode-hook'." - (when (not (y-or-n-p "Really change major mode in a Lui buffer? ")) - (error "User disallowed mode change"))) - -(defun lui-scroll-window (window _display-start) - "Scroll the input line to the bottom of the WINDOW. - -DISPLAY-START is passed by the hook `window-scroll-functions' and -is ignored. - -See `lui-scroll-behavior' for how to customize this." - (when (and (eq lui-scroll-behavior 'post-scroll) - window - (window-live-p window)) - (with-selected-window window - (when (or (>= (point) lui-input-marker) - (equal (point-max) - (window-end nil t))) - (let ((resize-mini-windows nil)) - (save-excursion - (goto-char (point-max)) - (recenter -1))))))) - -(defun lui-scroll-post-command () - "Scroll the input line to the bottom of the window. - -This is called from `post-command-hook'. - -See `lui-scroll-behavior' for how to customize this." - (condition-case err - (dolist (w (window-list)) - (with-current-buffer (window-buffer w) - (when (and lui-input-marker - (memq lui-scroll-behavior '(t post-command))) - ;; Code from ERC's erc-goodies.el. I think this was originally - ;; mine anyhow, not sure though. - (save-restriction - (widen) - (when (>= (point) lui-input-marker) - (save-excursion - (goto-char (point-max)) - (with-selected-window w - (recenter -1)))))))) - (error - (message "Error in lui-scroll-post-command: %S" err) - ))) - -(defun lui-scroll-post-output () - "Scroll the input line to the bottom of the window. - -This is called when lui output happens. - -See `lui-scroll-behavior' for how to customize this." - (when (memq lui-scroll-behavior '(t post-output)) - (let ((resize-mini-windows nil)) - (dolist (window (get-buffer-window-list (current-buffer) nil t)) - (when (or (>= (point) lui-input-marker) - (equal (point-max) - (window-end window))) - (with-selected-window window - (save-excursion - (goto-char (point-max)) - (recenter -1)))))))) - - -;;;;;;;;;;;;; -;;; Input ;;; -;;;;;;;;;;;;; - -(defun lui-send-input () - "Send the current input to the Lui application. -If point is not in the input area, insert a newline." - (interactive) - (if (< (point) lui-input-marker) - (newline) - (save-restriction - (narrow-to-region lui-input-marker (point-max)) - (run-hooks 'lui-pre-input-hook)) - (let ((input (buffer-substring lui-input-marker (point-max)))) - (delete-region lui-input-marker (point-max)) - (lui-add-input input) - (if lui-input-function - (funcall lui-input-function input) - (error "No input function specified"))))) - -(defun lui-add-input (input) - "Add INPUT as if entered by the user." - (ring-insert lui-input-ring input) - (setq lui-input-ring-index nil)) - - -;;;;;;;;;;;;;;; -;;; Buttons ;;; -;;;;;;;;;;;;;;; - -(define-button-type 'lui-button - 'supertype 'button - 'follow-link t - 'face 'lui-button-face) - -(defun lui-buttonize () - "Buttonize the current message." - (lui-buttonize-urls) - (lui-buttonize-custom) - (lui-buttonize-issues)) - -(defun lui-buttonize-custom () - "Add custom buttons to the current message. - -This uses `lui-buttons-list'." - (dolist (entry lui-buttons-list) - (let ((regex (nth 0 entry)) - (submatch (nth 1 entry)) - (function-or-url (nth 2 entry)) - (arg-matches (nthcdr 3 entry))) - (goto-char (point-min)) - (while (re-search-forward regex nil t) - ;; Ensure we're not inserting a button inside a URL button - (when (not (button-at (match-beginning 0))) - (let* ((function (if (functionp function-or-url) - function-or-url - 'browse-url)) - (matches (mapcar (lambda (n) - (match-string-no-properties n)) - arg-matches)) - (arguments (if (functionp function-or-url) - matches - (list (apply #'format function-or-url - matches))))) - (make-button (match-beginning submatch) - (match-end submatch) - 'type 'lui-button - 'action 'lui-button-activate - 'lui-button-function function - 'lui-button-arguments arguments))))))) - -(defun lui-buttonize-issues () - "Buttonize issue references in the current message, if configured." - (when lui-button-issue-tracker - (goto-char (point-min)) - (while (re-search-forward "\\(?:^\\|\\W\\)\\(#\\([0-9]+\\)\\)" nil t) - ;; Ensure we're not inserting a button inside a URL button - (when (not (button-at (point))) - (make-button (match-beginning 1) - (match-end 1) - 'type 'lui-button - 'action 'lui-button-activate - 'lui-button-function 'browse-url - 'lui-button-arguments - (list (format lui-button-issue-tracker - (match-string 2)))))))) - -(defun lui-buttonize-urls () - "Buttonize URLs in the current message." - (let ((regex (regexp-opt thing-at-point-uri-schemes))) - (goto-char (point-min)) - (while (re-search-forward regex nil t) - (let ((bounds (bounds-of-thing-at-point 'url))) - (when bounds - (make-button (car bounds) - (cdr bounds) - 'type 'lui-button - 'action 'lui-button-activate - 'lui-button-function 'browse-url - 'lui-button-arguments - (list (buffer-substring-no-properties - (car bounds) - (cdr bounds))))))))) - -(defun lui-button-activate (button) - "Activate BUTTON. -This calls the function stored in the `lui-button-function' -property with the argument stored in `lui-button-arguments'." - (apply (button-get button 'lui-button-function) - (button-get button 'lui-button-arguments))) - -(defun lui-next-button-or-complete () - "Go to the next button, or complete at point. -When point is in the input line, call `lui-completion-function'. -Otherwise, we move to the next button." - (interactive) - (if (>= (point) - lui-input-marker) - (funcall lui-completion-function) - (forward-button 1))) - -(defun lui-previous-button () - "Go to the previous button." - (interactive) - (backward-button 1)) - -(defun lui-button-elisp-symbol (name) - "Show the documentation for the symbol named NAME." - (let ((sym (intern-soft name))) - (cond - ((not sym) - (message "No such symbol %s" name) - (ding)) - (t - (help-xref-interned sym))))) - -(defun lui-button-pep (number) - "Browse the PEP NUMBER." - (browse-url (format "https://www.python.org/dev/peps/pep-%04i" - (string-to-number number)))) - -(defun lui-button-issue (issue) - "Browse the issue tracker number ISSUE, if configured." - (if lui-button-issue-tracker - (browse-url (format lui-button-issue-tracker issue)) - (error "No issue tracker configured, see `lui-button-issue-tracker'"))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Input Line Killing ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun lui-kill-to-beginning-of-line () - "Kill the input from point to the beginning of the input." - (interactive) - (let* ((beg (point-at-bol)) - (end (point)) - (str (buffer-substring beg end))) - (delete-region beg end) - (kill-new str))) - - -;;;;;;;;;;;;;;;;;;;;; -;;; Input History ;;; -;;;;;;;;;;;;;;;;;;;;; - -;; FIXME! -;; These need some better algorithm. They clobber input when it is not -;; in the ring! -(defun lui-previous-input () - "Cycle through the input history to the last input." - (interactive) - (when (> (ring-length lui-input-ring) 0) - (if (and lui-input-ring-index - (= (1- (ring-length lui-input-ring)) - lui-input-ring-index)) - ;; last item - insert a single empty line - (progn - (lui-replace-input "") - (setq lui-input-ring-index nil)) - ;; If any input is left, store it in the input ring - (when (and (null lui-input-ring-index) - (> (point-max) lui-input-marker)) - (ring-insert lui-input-ring - (buffer-substring lui-input-marker (point-max))) - (setq lui-input-ring-index 0)) - ;; Increment the index - (setq lui-input-ring-index - (if lui-input-ring-index - (ring-plus1 lui-input-ring-index (ring-length lui-input-ring)) - 0)) - ;; And insert the last input - (lui-replace-input (ring-ref lui-input-ring lui-input-ring-index)) - (goto-char (point-max))))) - -(defun lui-next-input () - "Cycle through the input history to the next input." - (interactive) - (when (> (ring-length lui-input-ring) 0) - (if (and lui-input-ring-index - (= 0 lui-input-ring-index)) - ;; first item - insert a single empty line - (progn - (lui-replace-input "") - (setq lui-input-ring-index nil)) - ;; If any input is left, store it in the input ring - (when (and (null lui-input-ring-index) - (> (point-max) lui-input-marker)) - (ring-insert lui-input-ring - (buffer-substring lui-input-marker (point-max))) - (setq lui-input-ring-index 0)) - ;; Decrement the index - (setq lui-input-ring-index (ring-minus1 (or lui-input-ring-index 0) - (ring-length lui-input-ring))) - ;; And insert the next input - (lui-replace-input (ring-ref lui-input-ring lui-input-ring-index)) - (goto-char (point-max))))) - -(defun lui-replace-input (str) - "Replace input with STR." - (save-excursion - (goto-char lui-input-marker) - (delete-region lui-input-marker (point-max)) - (insert str))) - - -;;;;;;;;;;;;; -;;; Fools ;;; -;;;;;;;;;;;;; - -(defun lui-fools () - "Propertize the current narrowing according to foolhardiness. -That is, if any part of it has the text property 'lui-fool set, -make the whole thing invisible." - (when (text-property-any (point-min) - (point-max) - 'lui-fool t) - (add-text-properties (point-min) - (point-max) - '(invisible lui-fool)))) - -(defun lui-fools-hidden-p () - "Return whether fools are currently hidden." - (if (or (eq t buffer-invisibility-spec) - (memq 'lui-fool buffer-invisibility-spec)) - t - nil)) - -(defun lui-fool-toggle-display () - "Display what fools have said." - (interactive) - (when (eq buffer-invisibility-spec t) - (add-to-invisibility-spec 'lui-fool)) - (cond - ((lui-fools-hidden-p) - (message "Now showing the gibberish of fools") - (remove-from-invisibility-spec 'lui-fool)) - (t - (message "Now hiding fools again *phew*") - (add-to-invisibility-spec 'lui-fool))) - ;; For some reason, after this, the display does not always update - ;; (issue #31). Force an update just in case. - (force-mode-line-update t)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Blink Paren and Show Paren Mode ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun lui-paren-highlighting () - "Enable sane parenthesis highlighting in this buffer." - (set (make-local-variable 'blink-paren-function) - 'lui-blink-paren-function) - (when (boundp 'show-paren-data-function) - (set (make-local-variable 'show-paren-data-function) - 'lui-show-paren-data-function))) - -(defun lui-blink-paren-function () - "Do not blink opening parens outside of the lui input area. - -When point is within the lui input area, inserting a closing -parenthesis should only blink parens within the input area, not -outside of it. - -This is a suitable value for `blink-paren-function', which see." - (if (> (point) lui-input-marker) - (let ((blink-matching-paren-distance (- (point) - lui-input-marker))) - (blink-matching-open)) - (blink-matching-open))) - -(defun lui-show-paren-data-function () - "Show parens only within the input area. - -When `show-paren-mode' is enabled, and point is in the input -area, parenthesis highlighting should only happen within the -input area, not include the rest of the buffer. - -This is a suitable value for `show-paren-data-function', which see." - (when (fboundp 'show-paren--default) - (let ((range (show-paren--default))) - (if (or (< (point) lui-input-marker) - (not (elt range 2)) - (>= (elt range 2) lui-input-marker)) - range - nil)))) - - -;;;;;;;;;;;;;;;; -;;; Flyspell ;;; -;;;;;;;;;;;;;;;; - -(defun lui-flyspell-change-dictionary (&optional dictionary) - "*Change flyspell to DICTIONARY. -If DICTIONARY is nil, set a default dictionary according to -`lui-flyspell-alist'. -If it is \"\", disable flyspell." - (interactive (list (completing-read - "Use new dictionary (RET for none, SPC to complete): " - (and (fboundp 'ispell-valid-dictionary-list) - (mapcar 'list (ispell-valid-dictionary-list))) - nil t))) - (let ((dictionary (or dictionary - (lui-find-dictionary (buffer-name))))) - (when flyspell-mode - (flyspell-mode 0)) - (when (and dictionary - (not (equal dictionary ""))) - (ispell-change-dictionary dictionary)) - (flyspell-mode 1))) - - -(defun lui-find-dictionary (buffer-name) - "Return a dictionary appropriate for BUFFER-NAME." - (let ((lis lui-flyspell-alist) - (result nil)) - (while lis - (if (string-match (caar lis) buffer-name) - (setq result (cadr (car lis)) - lis nil) - (setq lis (cdr lis)))) - result)) - -(defun lui-flyspell-check-word-p () - "Return non-nil when flyspell should verify at this position. -This is the value of Lui for `flyspell-generic-check-word-p'." - (>= (point) - lui-input-marker)) - - -;;;;;;;;;;;;;; -;;; Output ;;; -;;;;;;;;;;;;;; - -(defvar lui-message-id 0 - "Unique id for each message. -Used to allow navigation between messages and editing and -deleting.") -(make-variable-buffer-local 'lui-message-id) - -(defvar lui-internal-text-properties '(lui-formatted-time-stamp - lui-time-stamp-last - lui-raw-text - lui-message-id - lui-saved-text-properties) - "Text properties used internally by lui. - -These are always kept when replacing messages.") - -(defun lui-insert (str &optional not-tracked-p) - "Insert STR into the current Lui buffer. - -If NOT-TRACKED-P is given, this insertion won't trigger tracking -of the buffer." - (if not-tracked-p - (lui-insert-with-text-properties str 'not-tracked-p t) - (lui-insert-with-text-properties str))) - -(defun lui-plist-keys (plist) - "Get the keys from PLIST. - -PLIST should be a flat list with keys and values alternating, -like used for setting and getting text properties." - (let ((key t) result) - (dolist (item plist (reverse result)) - (when key - (push item result)) - (setq key (not key))))) - -(defun lui-insert-with-text-properties (str &rest text-properties) - "Insert STR into the current Lui buffer. - -TEXT-PROPERTIES is a property list containing text properties to -add to the inserted message." - (let ((not-tracked-p (plist-get text-properties 'not-tracked-p)) - (saved-text-properties (append (lui-plist-keys text-properties) - lui-internal-text-properties))) - (lui-save-undo-list - (save-excursion - (save-restriction - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t)) - (widen) - (goto-char lui-output-marker) - (let ((beg (point)) - (end nil)) - (insert str "\n") - (setq end (point)) - (set-marker lui-output-marker (point)) - (narrow-to-region beg end)) - (goto-char (point-min)) - (add-text-properties (point-min) - (point-max) - `(lui-raw-text ,str)) - (run-hooks 'lui-pre-output-hook) - (lui-apply-formatting) - (lui-highlight-keywords) - (lui-buttonize) - (lui-fill) - (lui-time-stamp - (plist-get text-properties 'lui-formatted-time-stamp)) - (goto-char (point-min)) - (add-text-properties - (point-min) (point-max) - (plist-put text-properties 'lui-message-id lui-message-id)) - (setq lui-message-id (1+ lui-message-id)) - (run-hooks 'lui-post-output-hook) - (lui-fools) - (goto-char (point-min)) - (add-text-properties - (point-min) (point-max) - `(lui-saved-text-properties ,saved-text-properties)) - (let ((faces (lui-faces-in-region (point-min) - (point-max))) - (foolish (text-property-any (point-min) - (point-max) - 'lui-fool t)) - (not-tracked-p - (or not-tracked-p - (text-property-any (point-min) - (point-max) - 'lui-do-not-track t)))) - (widen) - (lui-truncate) - (lui-read-only) - (when (and (not not-tracked-p) - (not foolish)) - (tracking-add-buffer (current-buffer) - faces))) - (lui-scroll-post-output))))))) - -(defun lui--adjust-p (pos old) - (and (numberp pos) (>= (abs pos) old))) - -(defun lui--new-pos (pos shift) - (* (if (< pos 0) -1 1) (+ (abs pos) shift))) - -(defun lui-adjust-undo-list (old-begin shift) - ;; Translate buffer positions in buffer-undo-list by SHIFT. - (unless (or (zerop shift) (atom buffer-undo-list)) - (let ((list buffer-undo-list) elt) - (while list - (setq elt (car list)) - (cond ((integerp elt) ; POSITION - (if (lui--adjust-p elt old-begin) - (setf (car list) (lui--new-pos elt shift)))) - ((or (atom elt) ; nil, EXTENT - (markerp (car elt))) ; (MARKER . DISTANCE) - nil) - ((integerp (car elt)) ; (BEGIN . END) - (if (lui--adjust-p (car elt) old-begin) - (setf (car elt) (lui--new-pos (car elt) shift))) - (if (lui--adjust-p (cdr elt) old-begin) - (setf (cdr elt) (lui--new-pos (cdr elt) shift)))) - ((stringp (car elt)) ; (TEXT . POSITION) - (if (lui--adjust-p (cdr elt) old-begin) - (setf (cdr elt) (lui--new-pos (cdr elt) shift)))) - ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) - (let ((cons (nthcdr 3 elt))) - (if (lui--adjust-p (car cons) old-begin) - (setf (car cons) (lui--new-pos (car cons) shift))) - (if (lui--adjust-p (cdr cons) old-begin) - (setf (cdr cons) (lui--new-pos (cdr cons) shift))))) - ((and (featurep 'xemacs) - (extentp (car elt))) ; (EXTENT START END) - (if (lui--adjust-p (nth 1 elt) old-begin) - (setf (nth 1 elt) (lui--new-pos (nth 1 elt) shift))) - (if (lui--adjust-p (nth 2 elt) old-begin) - (setf (nth 2 elt) (lui--new-pos (nth 2 elt) shift))))) - (setq list (cdr list)))))) - -(defvar lui-prompt-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "<end>") 'lui-prompt-end-of-line) - (define-key map (kbd "C-e") 'lui-prompt-end-of-line) - map) - "Keymap for Lui prompts. -Since \\[end-of-line] can't move out of fields, this DTRT for an -unexpecting user.") - -(defun lui-set-prompt (prompt) - "Set PROMPT as the current Lui prompt." - (let ((inhibit-read-only t)) - (lui-save-undo-list - (save-excursion - (goto-char lui-output-marker) - (insert prompt) - (if (> lui-input-marker (point)) - (delete-region (point) lui-input-marker) - (set-marker lui-input-marker (point))) - (add-text-properties lui-output-marker lui-input-marker - `(read-only t - rear-nonsticky t - field lui-prompt - keymap ,lui-prompt-map - front-sticky t - )))))) - -(defun lui-prompt-end-of-line (&optional _N) - "Move past the prompt, and then to the end of the line. -This uses `end-of-line'. - -The argument N is ignored." - (interactive "p") - (goto-char lui-input-marker) - (call-interactively 'end-of-line)) - -(defun lui-faces-in-region (beg end) - "Return a face that describes the region between BEG and END." - (goto-char beg) - (let ((faces nil)) - (while (not (= (point) end)) - (let ((face (get-text-property (point) 'face))) - (dolist (face (if (consp face) - face - (list face))) - (when (and face - (facep face) - (face-differs-from-default-p face)) - (push face faces))) - (goto-char (next-single-property-change (point) 'face - nil end)))) - faces)) - - - -;;;;;;;;;;;;;;;;;;;; -;;; Highlighting ;;; -;;;;;;;;;;;;;;;;;;;; - -(defun lui-highlight-keywords () - "Highlight the entries in the variable `lui-highlight-keywords'. - -This is called automatically when new text is inserted." - (let ((regex (lambda (entry) - (if (stringp entry) - entry - (car entry)))) - (submatch (lambda (entry) - (if (and (consp entry) - (numberp (cadr entry))) - (cadr entry) - 0))) - (properties (lambda (entry) - (let ((face (cond - ;; REGEXP - ((stringp entry) - 'lui-highlight-face) - ;; (REGEXP SUBMATCH) - ((and (numberp (cadr entry)) - (null (cddr entry))) - 'lui-highlight-face) - ;; (REGEXP FACE) - ((null (cddr entry)) - (cadr entry)) - ;; (REGEXP SUBMATCH FACE) - (t - (nth 2 entry))))) - (if (facep face) - `(face ,face) - face))))) - (dolist (entry lui-highlight-keywords) - (goto-char (point-min)) - (while (re-search-forward (funcall regex entry) nil t) - (let* ((exp (funcall submatch entry)) - (beg (match-beginning exp)) - (end (match-end exp))) - (when (not (text-property-any beg end 'lui-highlight-fontified-p t)) - (add-text-properties beg end - (append (funcall properties entry) - '(lui-highlight-fontified-p t))))))))) - -(defun lui-apply-formatting () - "Highlight the entries in `lui-formatting-list'." - (dolist (entry lui-formatting-list) - (goto-char (point-min)) - (let ((re (car entry)) - (subgroup (cadr entry)) - (face (nth 2 entry))) - (while (re-search-forward re nil t) - (when face - (add-face-text-property (match-beginning subgroup) (match-end subgroup) - face nil (current-buffer))))))) - - -;;;;;;;;;;;;;;; -;;; Filling ;;; -;;;;;;;;;;;;;;; - -(defun lui-fill () - "Fill the text in the buffer. -This is called automatically when new text is inserted. See -`lui-fill-type' and `lui-fill-column' on how to customize this -function." - (cond - ((stringp lui-fill-type) - (let ((fill-prefix lui-fill-type) - (fill-column (or lui-fill-column - fill-column))) - (fill-region (point-min) (point-max) - nil t))) - ((eq lui-fill-type 'variable) - (let ((fill-prefix (save-excursion - (goto-char (point-min)) - (let ((beg (point))) - (re-search-forward "\\s-" nil t) - (make-string (- (point) beg) ? )))) - (fill-column (or lui-fill-column - fill-column))) - (fill-region (point-min) (point-max) - nil t))) - ((numberp lui-fill-type) - (let ((right-end (save-excursion - (goto-char (point-min)) - (re-search-forward "\\s-" nil t) - (- (point) - (point-at-bol))))) - (goto-char (point-min)) - (when (< right-end lui-fill-type) - (insert (make-string (- lui-fill-type - right-end) - ? ))) - (let ((fill-prefix (make-string lui-fill-type ? )) - (fill-column (or lui-fill-column - fill-column))) - (fill-region (point-min) (point-max) - nil t))))) - (when lui-fill-remove-face-from-newline - (goto-char (point-min)) - (while (re-search-forward "\n" nil t) - (put-text-property (match-beginning 0) - (match-end 0) - 'face - nil)))) - - -;;;;;;;;;;;;;;;;;;; -;;; Time Stamps ;;; -;;;;;;;;;;;;;;;;;;; - -(defvar lui-time-stamp-last nil - "The last time stamp.") -(make-variable-buffer-local 'lui-time-stamp-last) - -(defvar lui-time-stamp-time nil - "A custom time to use as the time stamp for `lui-insert'. - -This variable should be let-bound when you wish to provide a -custom time to be printed by `lui-time-stamp'. If this variable -is nil the current time is used. See the TIME argument to -`format-time-string' for more information.") - -(defvar lui-time-stamp-zone nil - "A custom timezone to use for the time stamp for `lui-insert'. - -This variable should be let-bound when you wish to provide a -custom time zone when printing the time stamp with -`lui-time-stamp'. If this variable is nil local time is used. -See the ZONE argument to `format-time-string' for more -information.") - -(defun lui-time-stamp (&optional text) - "Add a time stamp to the current buffer. - -If TEXT is specified, use that instead of formatting a new time stamp." - (let ((ts (or text - (format-time-string lui-time-stamp-format - lui-time-stamp-time - lui-time-stamp-zone)))) - (cond - ;; Time stamps right - ((or (numberp lui-time-stamp-position) - (eq lui-time-stamp-position 'right)) - (when (or (not lui-time-stamp-only-when-changed-p) - (not lui-time-stamp-last) - (not (string= ts lui-time-stamp-last))) - (goto-char (point-min)) - (goto-char (point-at-eol)) - (let* ((curcol (current-column)) - (col (if (numberp lui-time-stamp-position) - lui-time-stamp-position - (+ 2 (or lui-fill-column - fill-column - (point))))) - (indent (if (> col curcol) - (- col curcol) - 1)) - (ts-string (propertize - (concat (make-string indent ?\s) - (propertize - ts - 'face 'lui-time-stamp-face)) - 'lui-time-stamp t)) - (start (point))) - (insert ts-string) - (add-text-properties start (1+ (point)) '(intangible t)) - (add-text-properties (1+ start) (point) '(cursor-intangible t))))) - ;; Time stamps left - ((eq lui-time-stamp-position 'left) - (let ((indent-string (propertize (make-string (length ts) ?\s) - 'lui-time-stamp t))) - (goto-char (point-min)) - (cond - ;; Time stamp - ((or (not lui-time-stamp-only-when-changed-p) - (not lui-time-stamp-last) - (not (string= ts lui-time-stamp-last))) - (insert (propertize ts - 'face 'lui-time-stamp-face - 'lui-time-stamp t))) - ;; Just indentation - (t - (insert indent-string))) - (forward-line 1) - (while (< (point) (point-max)) - (insert indent-string) - (forward-line 1)))) - ;; Time stamps in margin - ((or (eq lui-time-stamp-position 'right-margin) - (eq lui-time-stamp-position 'left-margin)) - (when (or (not lui-time-stamp-only-when-changed-p) - (not lui-time-stamp-last) - (not (string= ts lui-time-stamp-last))) - (goto-char (point-min)) - (when lui-fill-type - (goto-char (point-at-eol))) - (let* ((ts (propertize ts 'face 'lui-time-stamp-face)) - (ts-margin (propertize - " " - 'display `((margin ,lui-time-stamp-position) - ,ts) - 'lui-time-stamp t))) - (insert ts-margin))))) - (add-text-properties (point-min) (point-max) - `(lui-formatted-time-stamp ,ts - lui-time-stamp-last ,lui-time-stamp-last)) - (setq lui-time-stamp-last ts))) - -(defun lui-time-stamp-enable-filtering () - "Enable filtering of timestamps from copied text." - (set (make-local-variable 'filter-buffer-substring-functions) - '(lui-filter-buffer-time-stamps))) - -(defun lui-filter-buffer-time-stamps (fun beg end delete) - "Filter text from copied strings. - -This is meant for the variable `filter-buffer-substring-functions', -which see for an explanation of the argument FUN, BEG, END and -DELETE." - (let ((string (funcall fun beg end delete)) - (inhibit-point-motion-hooks t) - (inhibit-read-only t) - ;; Emacs 24.4, 24.5 - deactivate-mark) - (with-temp-buffer - (insert string) - (let ((start (text-property-any (point-min) - (point-max) - 'lui-time-stamp t))) - (while start - (let ((end (next-single-property-change start 'lui-time-stamp - nil (point-max)))) - (delete-region start end) - (setq start (text-property-any (point-min) (point-max) - 'lui-time-stamp t)))) - (buffer-string))))) - -(defun lui-time-stamp-buffer-substring (buffer-string) - "Filter text from copied strings. - -This is meant for the variable `buffer-substring-filters', -which see for an explanation of the argument BUFFER-STRING." - (lui-filter-buffer-time-stamps (lambda (_beg _end _delete) - buffer-string) - nil nil nil)) - - -;;;;;;;;;;;;;;;;;; -;;; Truncating ;;; -;;;;;;;;;;;;;;;;;; - -(defun lui-truncate () - "Truncate the current buffer if it exceeds `lui-max-buffer-size'." - (when (and lui-max-buffer-size - (> (point-max) - lui-max-buffer-size)) - (goto-char (- (point-max) - lui-max-buffer-size)) - (forward-line 0) - (let ((inhibit-read-only t)) - (delete-region (point-min) (point))))) - - -;;;;;;;;;;;;;;;;; -;;; Read-Only ;;; -;;;;;;;;;;;;;;;;; - -(defun lui-read-only () - "Make the current output read-only if `lui-read-only-output-p' is non-nil." - (when lui-read-only-output-p - (add-text-properties (point-min) lui-output-marker - '(read-only t - front-sticky t)))) - - -;;;;;;;;;;;;;;;;;; -;;; Navigation ;;; -;;;;;;;;;;;;;;;;;; - -(defun lui-at-message-p () - "Check if point is on a message." - (get-text-property (point) 'lui-message-id)) - -(defun lui-beginning-of-message-p () - "Check if point is at the beginning of a message." - (or (= (point) (point-min)) - (not (equal (get-text-property (point) 'lui-message-id) - (get-text-property (1- (point)) 'lui-message-id))))) - -(defun lui-beginning-of-message () - "Move point to the beginning of the message at point." - (goto-char (previous-single-property-change (point) 'lui-message-id))) - -(defun lui-forward-message () - "Move point to the next message in the buffer and return point. -If there is no next message, move to the end of the buffer instead." - (let ((current-id (get-text-property (point) 'lui-message-id)) - (next-point - (next-single-property-change (point) 'lui-message-id))) - (if (not next-point) - (goto-char (point-max)) - (let ((message-id - (get-text-property next-point 'lui-message-id))) - (goto-char next-point) - (when (or (not (or current-id message-id)) - (and current-id (not message-id)) - (and current-id message-id - (= current-id message-id))) - (lui-forward-message)))) - (point))) - -(defun lui-backward-message () - "Move point to the previous message in the buffer and return point. -If there is no previous message, move to the beginning of the -buffer instead." - (let ((current-id (get-text-property (point) 'lui-message-id)) - (prev-point - (previous-single-property-change (point) 'lui-message-id))) - (if (not prev-point) - (goto-char (point-min)) - (let ((message-id - (get-text-property prev-point 'lui-message-id))) - (goto-char prev-point) - (when (or (not (or current-id message-id)) - (and current-id (not message-id)) - (and current-id message-id - (= current-id message-id))) - (lui-backward-message)))) - (point))) - - -;;;;;;;;;;;;;;; -;;; Editing ;;; -;;;;;;;;;;;;;;; - -(defun lui-recover-output-marker () - "Reset the output marker to just before the lui prompt." - (let ((input-position (marker-position lui-input-marker))) - (set-marker lui-output-marker - (field-beginning (1- input-position))))) - -(defun lui-build-plist (keys) - "Build a plist with KEYS taken from current text properties." - (let (result) - (dolist (key keys result) - (let ((value (get-text-property (point) key))) - (when value - (setq result (plist-put result key value))))))) - -(defun lui-replace-message (new-message) - "Replace the message at point with NEW-MESSAGE." - (unless (lui-at-message-p) - (error "Point is not on a message")) - (unless (lui-beginning-of-message-p) - (lui-beginning-of-message)) - (let* ((saved-text-properties - (get-text-property (point) 'lui-saved-text-properties)) - (text-properties (lui-build-plist saved-text-properties)) - (inhibit-read-only t) - (lui-time-stamp-last - (get-text-property (point) 'lui-time-stamp-last)) - (lui-message-id - (get-text-property (point) 'lui-message-id))) - (unwind-protect - (progn - (setq lui-output-marker (point-marker)) - (delete-region (point) - (next-single-property-change (point) 'lui-message-id)) - (apply #'lui-insert-with-text-properties new-message - (plist-put text-properties 'not-tracked-p t))) - (lui-recover-output-marker)))) - -(defun lui-replace (new-message predicate) - "Replace a message with NEW-MESSAGE. - -PREDICATE should be a function that returns a non-nil value for -the message that should be replaced." - (save-excursion - (goto-char (point-max)) - (while (> (lui-backward-message) (point-min)) - (when (funcall predicate) - (lui-replace-message new-message))))) - -(defun lui-delete-message () - "Delete the message at point." - (unless (lui-at-message-p) - (error "Point is not on a message")) - (unless (lui-beginning-of-message-p) - (lui-beginning-of-message)) - (let ((inhibit-read-only t)) - (add-text-properties (point) - (next-single-property-change (point) 'lui-message-id) - '(face lui-deleted-face)))) - -(defun lui-delete (predicate) - "Delete a message. - -PREDICATE should be a function that returns a non-nil value for -the message that should be replaced." - (save-excursion - (goto-char (point-max)) - (while (> (lui-backward-message) (point-min)) - (when (funcall predicate) - (lui-delete-message))))) - - -(provide 'lui) -;;; lui.el ends here |