update
This commit is contained in:
Yann Esposito (Yogsototh)
parent
b9b2950b41
commit
20c66c2aaf
GPG key ID:
7B19A4C650D59646
62 changed files with 4419 additions and 1148 deletions
|
|
@ -877,7 +877,7 @@
|
|||
(:keywords "gnome" "c" "coding style")
|
||||
(:url . "http://elpa.gnu.org/packages/gnome-c-style.html"))])
|
||||
(gnorb .
|
||||
[(1 6 6)
|
||||
[(1 6 7)
|
||||
((cl-lib
|
||||
(0 5)))
|
||||
"Glue code between Gnus, Org, and BBDB" tar
|
||||
|
|
@ -1096,7 +1096,7 @@
|
|||
("Simen Heggestøyl" . "simenheg@gmail.com"))
|
||||
(:maintainer "Simen Heggestøyl" . "simenheg@gmail.com"))])
|
||||
(jsonrpc .
|
||||
[(1 0 9)
|
||||
[(1 0 11)
|
||||
((emacs
|
||||
(25 2)))
|
||||
"JSON-RPC library" single
|
||||
|
|
@ -1281,7 +1281,7 @@
|
|||
("Michael Abraham Shulman" . "viritrilbia@gmail.com"))
|
||||
(:keywords "convenience" "faces" "languages" "tools"))])
|
||||
(modus-operandi-theme .
|
||||
[(0 7 0)
|
||||
[(0 8 1)
|
||||
((emacs
|
||||
(26 1)))
|
||||
"Accessible light theme (WCAG AAA)" single
|
||||
|
|
@ -1291,7 +1291,7 @@
|
|||
(:maintainer "Protesilaos Stavrou" . "info@protesilaos.com")
|
||||
(:url . "https://gitlab.com/protesilaos/modus-themes"))])
|
||||
(modus-vivendi-theme .
|
||||
[(0 7 0)
|
||||
[(0 8 1)
|
||||
((emacs
|
||||
(26 1)))
|
||||
"Accessible dark theme (WCAG AAA)" single
|
||||
|
|
@ -1556,7 +1556,7 @@
|
|||
("Phillip Lord" . "phillip.lord@russet.org.uk"))
|
||||
(:url . "http://elpa.gnu.org/packages/persist.html"))])
|
||||
(phps-mode .
|
||||
[(0 3 44)
|
||||
[(0 3 45)
|
||||
((emacs
|
||||
(26)))
|
||||
"Major mode for PHP with Semantic integration" tar
|
||||
|
|
@ -1774,9 +1774,9 @@
|
|||
("Bastien Guerry" . "bzg@gnu.org"))
|
||||
(:maintainer "Bastien Guerry" . "bzg@gnu.org"))])
|
||||
(relint .
|
||||
[(1 15)
|
||||
[(1 16)
|
||||
((xr
|
||||
(1 17))
|
||||
(1 19))
|
||||
(emacs
|
||||
(26 1)))
|
||||
"Elisp regexp mistake finder" tar
|
||||
|
|
@ -2072,7 +2072,7 @@
|
|||
("Oleh Krehel" . "ohwoeowho@gmail.com"))
|
||||
(:keywords "convenience"))])
|
||||
(tramp .
|
||||
[(2 4 3 3)
|
||||
[(2 4 3 4)
|
||||
((emacs
|
||||
(24 4)))
|
||||
"Transparent Remote Access, Multiple Protocol" tar
|
||||
|
|
@ -2368,7 +2368,7 @@
|
|||
("Thien-Thi Nguyen" . "ttn@gnu.org"))
|
||||
(:keywords "multimedia" "xpm"))])
|
||||
(xr .
|
||||
[(1 18)
|
||||
[(1 19)
|
||||
((emacs
|
||||
(26 1)))
|
||||
"Convert string regexp to rx notation" tar
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Good signature from 066DAFCB81E42C40 GNU ELPA Signing Agent (2019) <elpasign@elpa.gnu.org> (trust undefined) created at 2020-03-09T22:05:02+0100 using RSA
|
||||
Good signature from 066DAFCB81E42C40 GNU ELPA Signing Agent (2019) <elpasign@elpa.gnu.org> (trust undefined) created at 2020-05-04T23:05:03+0200 using RSA
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,2 +1,2 @@
|
|||
(1 (org . [(20200427) ( ) "Outline-based notes management and organizer" tar])
|
||||
(org-plus-contrib . [(20200427) ( ) "Outline-based notes management and organizer" tar]))
|
||||
(1 (org . [(20200504) ( ) "Outline-based notes management and organizer" tar])
|
||||
(org-plus-contrib . [(20200504) ( ) "Outline-based notes management and organizer" tar]))
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "closql" '("closql-" "eieio-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("closql-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -11,6 +11,10 @@
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "deferred" '("deferred:")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("deferred-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -1,44 +0,0 @@
|
|||
;;; fill-column-indicator-autoloads.el --- automatically extracted autoloads
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(add-to-list 'load-path (directory-file-name
|
||||
(or (file-name-directory #$) (car load-path))))
|
||||
|
||||
|
||||
;;;### (autoloads nil "fill-column-indicator" "fill-column-indicator.el"
|
||||
;;;;;; (0 0 0 0))
|
||||
;;; Generated autoloads from fill-column-indicator.el
|
||||
|
||||
(autoload 'fci-mode "fill-column-indicator" "\
|
||||
Toggle fci-mode on and off.
|
||||
Fci-mode indicates the location of the fill column by drawing a
|
||||
thin line (a `rule') at the fill column.
|
||||
|
||||
With prefix ARG, turn fci-mode on if and only if ARG is positive.
|
||||
|
||||
The following options control the appearance of the fill-column
|
||||
rule: `fci-rule-column', `fci-rule-width', `fci-rule-color',
|
||||
`fci-rule-use-dashes', `fci-dash-pattern', `fci-rule-character',
|
||||
and `fci-rule-character-color'. For further options, see the
|
||||
Customization menu or the package file. (See the latter for tips
|
||||
on troubleshooting.)
|
||||
|
||||
\(fn &optional ARG)" t nil)
|
||||
|
||||
(autoload 'turn-on-fci-mode "fill-column-indicator" "\
|
||||
Turn on fci-mode unconditionally.
|
||||
|
||||
\(fn)" t nil)
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fill-column-indicator" '("fci-" "turn-off-fci-mode")))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
;; version-control: never
|
||||
;; no-byte-compile: t
|
||||
;; no-update-autoloads: t
|
||||
;; coding: utf-8
|
||||
;; End:
|
||||
;;; fill-column-indicator-autoloads.el ends here
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
;;; -*- no-byte-compile: t -*-
|
||||
(define-package "fill-column-indicator" "20191109.10" "Graphically indicate the fill column" 'nil :commit "3d88b8a4a3eeabb8d1c9ef27d3c6f5d98517be77" :keywords '("convenience") :authors '(("Alp Aker" . "alp.tekin.aker@gmail.com")) :maintainer '("Alp Aker" . "alp.tekin.aker@gmail.com"))
|
||||
|
|
@ -1,882 +0,0 @@
|
|||
;;; fill-column-indicator.el --- Graphically indicate the fill column
|
||||
|
||||
;; Copyright (c) 2011-2017 Alp Aker
|
||||
|
||||
;; Author: Alp Aker <alp.tekin.aker@gmail.com>
|
||||
;; Version: 1.90
|
||||
;; Package-Version: 20191109.10
|
||||
;; Keywords: convenience
|
||||
|
||||
;; 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.
|
||||
|
||||
;; A copy of the GNU General Public License can be obtained from the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
|
||||
;; MA 02111-1307 USA
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Many modern editors and IDEs can graphically indicate the location of the
|
||||
;; fill column by drawing a thin line (in design parlance, a `rule') down the
|
||||
;; length of the editing window. Fill-column-indicator implements this
|
||||
;; facility in Emacs.
|
||||
|
||||
;; Installation and Usage
|
||||
;; ======================
|
||||
|
||||
;; Put this file in your load path and put:
|
||||
;;
|
||||
;; (require 'fill-column-indicator)
|
||||
;;
|
||||
;; in your init file.
|
||||
|
||||
;; To toggle graphical indication of the fill column in a buffer, use the
|
||||
;; command `fci-mode'.
|
||||
|
||||
;; Configuration
|
||||
;; =============
|
||||
|
||||
;; By default, fci-mode draws its vertical indicator at the fill column. If
|
||||
;; you'd like it to be drawn at another column, set `fci-rule-column' to the
|
||||
;; column number. (A case in which this might be useful is when you want to
|
||||
;; fill comments at, for example, column 70, but want a vertical rule at
|
||||
;; column 80 or 100 to indicate the maximum line length for code.) The
|
||||
;; default behavior (showing the indicator at the fill column) is specified
|
||||
;; by setting fci-rule-column to nil.
|
||||
|
||||
;; On graphical displays the fill-column rule is drawn using a bitmap
|
||||
;; image. Its color is controlled by the variable `fci-rule-color', whose
|
||||
;; value can be any valid color name. The rule's width in pixels is
|
||||
;; determined by the variable `fci-rule-width'; the default value is 1.
|
||||
|
||||
;; The rule can be drawn as a solid or dashed line, controlled by the
|
||||
;; variable `fci-rule-use-dashes'; the default is nil. The dash appearance is
|
||||
;; controlled by `fci-dash-pattern', which is the ratio of dash length to
|
||||
;; line height; the default is 0.75. (The value should be a number between 0
|
||||
;; and 1; values outside that interval are coerced to the nearest endpoint.)
|
||||
|
||||
;; The image formats fci-mode can use are XPM and PBM. If Emacs has been
|
||||
;; compiled with the appropriate library it uses XPM images by default; if
|
||||
;; not it uses PBM images, which are natively supported. You can specify a
|
||||
;; particular choice of format by setting `fci-rule-image-format' explicitly
|
||||
;; to xpm or pbm.
|
||||
|
||||
;; On character terminals the rule is drawn using the character specified by
|
||||
;; `fci-rule-character'; the default is `|' (ascii 124). If
|
||||
;; `fci-rule-character-color' is nil, then it is drawn using fci-rule-color
|
||||
;; (or the closest approximation thereto that the terminal is capable of); if
|
||||
;; it is a color name, then that color is used instead.
|
||||
|
||||
;; If you'd like the rule to be drawn using fci-rule-character even on
|
||||
;; graphical displays, set `fci-always-use-textual-rule' to a non-nil value.
|
||||
|
||||
;; These variables (as well as those described in the next section) can be
|
||||
;; given buffer-local bindings.
|
||||
|
||||
;; Other Options
|
||||
;; =============
|
||||
|
||||
;; When `truncate-lines' is nil, the effect of drawing a fill-column rule is
|
||||
;; very odd looking. Indeed, it makes little sense to use a rule to indicate
|
||||
;; the position of the fill column in that case (the positions at which the
|
||||
;; fill column falls in the visual display space won't, in general, be
|
||||
;; collinear). For this reason, fci-mode sets truncate-lines to t in buffers
|
||||
;; in which it is enabled and restores it to its previous value when
|
||||
;; disabled. You can turn this feature off by setting
|
||||
;; `fci-handle-truncate-lines' to nil.
|
||||
|
||||
;; If `line-move-visual' is t, then vertical navigation can behave oddly in
|
||||
;; several edge cases while fci-mode is enabled (this is due to a bug in
|
||||
;; Emacs's C code). Accordingly, fci-mode sets line-move-visual to nil in
|
||||
;; buffers in which it is enabled and restores it to its previous value when
|
||||
;; disabled. This can be suppressed by setting `fci-handle-line-move-visual'
|
||||
;; to nil. (But you shouldn't want to do this. There's no reason to use
|
||||
;; line-move-visual if truncate-lines is t, and it doesn't make sense to use
|
||||
;; something like fci-mode when truncate-lines is nil.)
|
||||
|
||||
;; Fci-mode needs free use of two characters (specifically, it needs the use
|
||||
;; of two characters whose display table entries it can change
|
||||
;; arbitrarily). Its default is to use the first two characters of the
|
||||
;; Private Use Area of the Unicode BMP, viz. U+E000 and U+E001. If you need
|
||||
;; to use those characters for some other purpose, set `fci-eol-char' and
|
||||
;; `fci-blank-char' to different values.
|
||||
|
||||
;; Troubleshooting
|
||||
;; ===============
|
||||
|
||||
;; o Fci-mode is intended to be used with monospaced fonts. If you're using
|
||||
;; a monospaced font and the fill-column rule is missing or misaligned on a
|
||||
;; few lines but otherwise appears normal, then most likely (a) there are
|
||||
;; non-ascii characters on those lines that are being displayed using a
|
||||
;; non-monospaced font, or (b) your font-lock settings use bold or italics
|
||||
;; and those font variants aren't monospaced.
|
||||
|
||||
;; o Fci-mode in not currently compatible with Emacs's
|
||||
;; `show-trailing-whitespace' feature (given the way the latter is
|
||||
;; implemented, such compatibility is going to be hard to achieve). A
|
||||
;; workaround is to configure `whitespace-mode' to replicate the
|
||||
;; functionality of show-trailing-whitespace. This can be done with the
|
||||
;; following setting:
|
||||
;;
|
||||
;; (setq whitespace-style '(face trailing))
|
||||
;;
|
||||
;; With this, whitespace-mode produces the same basic effect as a non-nil
|
||||
;; value of show-trailing-whitespace, and compatibility with fci-mode is not
|
||||
;; a problem.
|
||||
|
||||
;; Known Issues
|
||||
;; ============
|
||||
|
||||
;; o The indicator extends only to end of the buffer contents (as opposed to
|
||||
;; running the full length of the editing window).
|
||||
|
||||
;; o When portions of a buffer are invisible, such as when outline-mode is
|
||||
;; used to hide certain lines, the fill-column rule is hidden as well.
|
||||
|
||||
;; o Fci-mode should work smoothly when simultaneously displaying the same
|
||||
;; buffer on both a graphical display and on a character terminal. It does
|
||||
;; not currently support simultaneous display of the same buffer on window
|
||||
;; frames with different default font sizes. (It would be feasible to
|
||||
;; support this use case, but thus far there seems to be no demand for
|
||||
;; it.)
|
||||
|
||||
;; Todo
|
||||
;; ====
|
||||
|
||||
;; o Accommodate non-nil values of `hl-line-sticky-flag' and similar cases.
|
||||
|
||||
;; o Accommodate linum-mode more robustly.
|
||||
|
||||
;; o Compatibility with non-nil `show-trailing-whitespace.'
|
||||
|
||||
;; Acknowledgements
|
||||
;; ================
|
||||
|
||||
;; Thanks to Ami Fischman, Christopher Genovese, Michael Hoffman, José
|
||||
;; Alfredo Romero L., R. Lange, Joe Lisee, José Lombera, Frank Meffert,
|
||||
;; Mitchell Peabody, sheijk, and an anonymous BT subscriber for bug reports
|
||||
;; and suggestions. Special thanks for code contributions: lomew, John Lamp,
|
||||
;; Sean Perry, David Röthlisberger, Pär Wieslander.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(unless (version<= "25" emacs-version)
|
||||
(error "Fill-column-indicator requires version 25 or later"))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; User Options
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
(defgroup fill-column-indicator nil
|
||||
"Graphically indicate the fill-column."
|
||||
:tag "Fill-Column Indicator"
|
||||
:group 'convenience
|
||||
:group 'fill)
|
||||
|
||||
;; We should be using :validate instead of :match, but that seems not to
|
||||
;; work with defcustom widgets.
|
||||
(defcustom fci-rule-column nil
|
||||
"Controls where fci-mode displays a vertical line (rule).
|
||||
|
||||
If nil, the rule is drawn at the fill column. Otherwise, it is
|
||||
drawn at the column given by this variable.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:group 'fill-column-indicator
|
||||
:tag "Fill-Column rule column"
|
||||
:type '(choice (const :tag "Use the fill column" nil)
|
||||
(integer :tag "Use a custom column"
|
||||
:match (lambda (w val) (fci-posint-p val)))))
|
||||
|
||||
(defcustom fci-rule-color "#cccccc"
|
||||
"Color used to draw the fill-column rule.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:group 'fill-column-indicator
|
||||
:tag "Fill-column rule color"
|
||||
:type 'color)
|
||||
|
||||
(defcustom fci-rule-width 1
|
||||
"Width in pixels of the fill-column rule on graphical displays.
|
||||
Note that a value greater than the default character width is
|
||||
treated as equivalent to the default character width.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:tag "Fill-Column Rule Width"
|
||||
:group 'fill-column-indicator
|
||||
:type '(integer :match (lambda (w val) (fci-posint-p val))))
|
||||
|
||||
(defcustom fci-rule-image-format
|
||||
(if (image-type-available-p 'xpm) 'xpm 'pbm)
|
||||
"Image format used for the fill-column rule on graphical displays.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:tag "Fill-Column Rule Image Format"
|
||||
:group 'fill-column-indicator
|
||||
:type '(choice (symbol :tag "XPM" 'xpm)
|
||||
(symbol :tag "PBM" 'pbm)))
|
||||
|
||||
(defcustom fci-rule-use-dashes nil
|
||||
"Whether to show the fill-column rule as dashes or as a solid line.
|
||||
This has no effect on non-graphical displays.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:tag "Fill-Column Rule Use Dashes"
|
||||
:group 'fill-column-indicator
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom fci-dash-pattern 0.75
|
||||
"When using a dashed rule, ratio of dash length to line height.
|
||||
Values less than 0 or greater than 1 are coerced to the nearest
|
||||
endpoint of that interval.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:tag "Fill-Column Rule Use Dashes"
|
||||
:group 'fill-column-indicator
|
||||
:type 'float)
|
||||
|
||||
(defcustom fci-rule-character ?|
|
||||
"Character used to draw the fill-column rule on character terminals.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:tag "Fill-Column Rule Character"
|
||||
:group 'fill-column-indicator
|
||||
:type 'character)
|
||||
|
||||
(defcustom fci-rule-character-color nil
|
||||
"Color used to draw the fill-column rule on character terminals.
|
||||
If nil, the same color is used as for the graphical rule.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:group 'fill-column-indicator
|
||||
:tag "Fill-column rule color"
|
||||
:type '(choice (const :tag "Use same color as graphical rule" nil)
|
||||
(color :tag "Specify a color")))
|
||||
|
||||
(defcustom fci-always-use-textual-rule nil
|
||||
"When non-nil, the rule is always drawn using textual characters.
|
||||
Specifically, fci-mode will use `fci-rule-character' instead of
|
||||
bitmap images to draw the rule on graphical displays.
|
||||
|
||||
Changes to this variable do not take effect until the mode
|
||||
function `fci-mode' is run."
|
||||
:tag "Don't Use Image for Fill-Column Rule"
|
||||
:group 'fill-column-indicator
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom fci-handle-truncate-lines t
|
||||
"Whether fci-mode should set truncate-lines to t while enabled.
|
||||
If non-nil, fci-mode will set truncate-lines to t in buffers in
|
||||
which it is enabled, and restore it to its previous value when
|
||||
disabled.
|
||||
|
||||
Leaving this option set to the default value is recommended."
|
||||
:group 'fill-column-indicator
|
||||
:tag "Locally set truncate-lines to t during fci-mode"
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom fci-handle-line-move-visual t
|
||||
"Whether fci-mode should set line-move-visual to nil while enabled.
|
||||
If non-nil, fci-mode will set line-move-visual to nil in buffers
|
||||
in which it is enabled, and restore t to its previous value when
|
||||
disabled.
|
||||
|
||||
Leaving this option set to the default value is recommended."
|
||||
:group 'fill-column-indicator
|
||||
:tag "Locally set line-move-visual to nil during fci-mode"
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom fci-eol-char ?\uE000
|
||||
"Character used for internal purposes by fci-mode.
|
||||
If you need to use this character, set this variable's value to a
|
||||
character you do not care about (a good choice is a character
|
||||
from the Private Use Area of the Unicode BMP, i.e., the range
|
||||
U+E000-U+F8FF, inclusive)."
|
||||
:group 'fill-column-indicator
|
||||
:type 'character)
|
||||
|
||||
(defcustom fci-blank-char ?\uE001
|
||||
"Character used for internal purposes by fci-mode.
|
||||
If you need to use this character, set this variable's value to a
|
||||
character you do not care about (a good choice is a character
|
||||
from the Private Use Area of the Unicode BMP, i.e., the the range
|
||||
U+E000-U+F8FF, inclusive)."
|
||||
:group 'fill-column-indicator
|
||||
:type 'character)
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Internal Variables and Constants
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
;; Record prior state of buffer.
|
||||
(defvar fci-saved-line-move-visual)
|
||||
(defvar fci-line-move-visual-was-buffer-local)
|
||||
(defvar fci-saved-truncate-lines)
|
||||
(defvar fci-saved-eol)
|
||||
(defvar fci-made-display-table)
|
||||
|
||||
;; Record state of fci initialization in this buffer.
|
||||
(defvar fci-display-table-processed)
|
||||
(defvar fci-local-vars-set)
|
||||
|
||||
;; Record current state of some quantities, so we can detect changes to them.
|
||||
(defvar fci-column)
|
||||
(defvar fci-newline)
|
||||
(defvar fci-tab-width)
|
||||
(defvar fci-char-width)
|
||||
(defvar fci-char-height)
|
||||
|
||||
;; Data used in setting the fill-column rule that only need to be
|
||||
;; occasionally updated in a given buffer.
|
||||
(defvar fci-limit)
|
||||
(defvar fci-pre-limit-string)
|
||||
(defvar fci-at-limit-string)
|
||||
(defvar fci-post-limit-string)
|
||||
|
||||
;; The preceding internal variables need to be buffer local and reset when
|
||||
;; the mode is disabled.
|
||||
(defconst fci-internal-vars '(fci-saved-line-move-visual
|
||||
fci-line-move-visual-was-buffer-local
|
||||
fci-saved-truncate-lines
|
||||
fci-saved-eol
|
||||
fci-made-display-table
|
||||
fci-display-table-processed
|
||||
fci-local-vars-set
|
||||
fci-column
|
||||
fci-newline
|
||||
fci-tab-width
|
||||
fci-char-width
|
||||
fci-char-height
|
||||
fci-limit
|
||||
fci-pre-limit-string
|
||||
fci-at-limit-string
|
||||
fci-post-limit-string))
|
||||
|
||||
(dolist (var fci-internal-vars)
|
||||
(make-variable-buffer-local var))
|
||||
|
||||
;; Hooks we use.
|
||||
(defconst fci-hook-assignments
|
||||
'((after-change-functions fci-redraw-region t t)
|
||||
(before-change-functions fci-extend-rule-for-deletion nil t)
|
||||
(window-scroll-functions fci-update-window-for-scroll nil t)
|
||||
(window-configuration-change-hook fci-redraw-frame)
|
||||
(post-command-hook fci-post-command-check nil t)
|
||||
(change-major-mode-hook turn-off-fci-mode nil t)
|
||||
(longlines-mode-hook fci-update-all-windows nil t)))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Miscellany
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
(defun fci-get-buffer-windows (&optional all-frames)
|
||||
"Return a list of windows displaying the current buffer."
|
||||
(get-buffer-window-list (current-buffer) 'no-minibuf all-frames))
|
||||
|
||||
(defun fci-posint-p (x)
|
||||
"Return true if X is an integer greater than zero."
|
||||
(and (wholenump x)
|
||||
(/= 0 x)))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Mode Definition
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
;;;###autoload
|
||||
(define-minor-mode fci-mode
|
||||
"Toggle fci-mode on and off.
|
||||
Fci-mode indicates the location of the fill column by drawing a
|
||||
thin line (a `rule') at the fill column.
|
||||
|
||||
With prefix ARG, turn fci-mode on if and only if ARG is positive.
|
||||
|
||||
The following options control the appearance of the fill-column
|
||||
rule: `fci-rule-column', `fci-rule-width', `fci-rule-color',
|
||||
`fci-rule-use-dashes', `fci-dash-pattern', `fci-rule-character',
|
||||
and `fci-rule-character-color'. For further options, see the
|
||||
Customization menu or the package file. (See the latter for tips
|
||||
on troubleshooting.)"
|
||||
|
||||
nil nil nil
|
||||
|
||||
(if fci-mode
|
||||
;; Enabling.
|
||||
(condition-case error
|
||||
(progn
|
||||
(fci-check-user-options)
|
||||
(fci-process-display-table)
|
||||
(fci-set-local-vars)
|
||||
(fci-get-frame-dimens)
|
||||
(dolist (hook fci-hook-assignments)
|
||||
(apply 'add-hook hook))
|
||||
(setq fci-column (or fci-rule-column fill-column)
|
||||
fci-tab-width tab-width
|
||||
fci-limit (if fci-newline
|
||||
(1+ (- fci-column (length fci-saved-eol)))
|
||||
fci-column))
|
||||
(fci-make-overlay-strings)
|
||||
(fci-update-all-windows t))
|
||||
(error
|
||||
(fci-mode 0)
|
||||
(signal (car error) (cdr error))))
|
||||
;; Disabling.
|
||||
(fci-restore-display-table)
|
||||
(fci-restore-local-vars)
|
||||
(dolist (hook fci-hook-assignments)
|
||||
(remove-hook (car hook) (nth 1 hook) (nth 3 hook)))
|
||||
(fci-delete-overlays-buffer)
|
||||
(dolist (var fci-internal-vars)
|
||||
(set var nil))))
|
||||
|
||||
;;;###autoload
|
||||
(defun turn-on-fci-mode ()
|
||||
"Turn on fci-mode unconditionally."
|
||||
(interactive)
|
||||
(fci-mode 1))
|
||||
|
||||
(defun turn-off-fci-mode ()
|
||||
"Turn off fci-mode unconditionally."
|
||||
(interactive)
|
||||
(fci-mode 0))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Display Property Specs
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
(defun fci-overlay-fills-background-p (olay)
|
||||
"Return true if OLAY specifies a background color."
|
||||
(let ((olay-face (overlay-get olay 'face)))
|
||||
(when olay-face
|
||||
(if (facep olay-face)
|
||||
(not (eq (face-attribute olay-face :background nil t) 'unspecified))
|
||||
(if (consp olay-face)
|
||||
(if (listp (cdr olay-face))
|
||||
(if (facep (car olay-face))
|
||||
(not (memq t (mapcar #'(lambda (f) (eq (face-attribute f :background nil t) 'unspecified))
|
||||
olay-face)))
|
||||
(plist-member olay-face :background))
|
||||
(eq (car olay-face) 'background-color)))))))
|
||||
|
||||
(defun fci-competing-overlay-p (posn)
|
||||
"Return true if there is an overlay at POSN that fills the background."
|
||||
(memq t (mapcar #'fci-overlay-fills-background-p (overlays-at posn))))
|
||||
|
||||
;; The display spec used in overlay before strings to pad out the rule to the
|
||||
;; fill-column.
|
||||
(defconst fci-padding-display
|
||||
'((when (not (fci-competing-overlay-p buffer-position))
|
||||
. (space :align-to fci-column))
|
||||
(space :width 0)))
|
||||
|
||||
;; Generate the display spec for the rule. Basic idea is to use a "cascading
|
||||
;; display property" to display the textual rule if the display doesn't
|
||||
;; support images and the graphical rule if it does, but in either case only
|
||||
;; display a rule if no other overlay wants to fill the background at the
|
||||
;; relevant buffer position.
|
||||
(defun fci-rule-display (blank rule-img rule-str for-pre-string)
|
||||
"Generate a display specification for a fill-column rule overlay string."
|
||||
(let* ((cursor-prop (if (and (not for-pre-string) (not fci-newline)) t))
|
||||
(propertized-rule-str (propertize rule-str 'cursor cursor-prop))
|
||||
(display-prop (if rule-img
|
||||
`((when (not (or (display-images-p)
|
||||
(fci-competing-overlay-p buffer-position)))
|
||||
. ,propertized-rule-str)
|
||||
(when (not (fci-competing-overlay-p buffer-position))
|
||||
. ,rule-img)
|
||||
(space :width 0))
|
||||
`((when (not (fci-competing-overlay-p buffer-position))
|
||||
. ,propertized-rule-str)
|
||||
(space :width 0)))))
|
||||
(propertize blank 'cursor cursor-prop 'display display-prop)))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Enabling
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
(defun fci-check-user-options ()
|
||||
"Check that all user options for fci-mode have valid values."
|
||||
(unless (memq fci-rule-image-format '(xpm pbm))
|
||||
(error "Unrecognized value of `fci-rule-image-format'"))
|
||||
;; If the third element of a binding form is t, then nil is an acceptable
|
||||
;; value for the variable; otherwise, the variable value must satisfy the
|
||||
;; given predicate.
|
||||
(let ((checks '((fci-rule-color color-defined-p)
|
||||
(fci-rule-column fci-posint-p t)
|
||||
(fci-rule-width fci-posint-p t)
|
||||
(fci-rule-character-color color-defined-p t)
|
||||
(fci-rule-character characterp)
|
||||
(fci-blank-char characterp)
|
||||
(fci-dash-pattern floatp)
|
||||
(fci-eol-char characterp))))
|
||||
(dolist (check checks)
|
||||
(let ((value (symbol-value (nth 0 check)))
|
||||
(pred (nth 1 check))
|
||||
(nil-is-ok (nth 2 check)))
|
||||
(unless (or (and nil-is-ok (null value))
|
||||
(funcall pred value))
|
||||
(signal 'wrong-type-argument (list pred value)))))))
|
||||
|
||||
(defun fci-process-display-table ()
|
||||
"Set up a buffer-local display table for fci-mode."
|
||||
(unless fci-display-table-processed
|
||||
(unless buffer-display-table
|
||||
(setq buffer-display-table (make-display-table)
|
||||
fci-made-display-table t))
|
||||
(aset buffer-display-table fci-blank-char [32])
|
||||
(setq fci-saved-eol (aref buffer-display-table 10))
|
||||
;; Assumption: the display-table entry for character 10 is either nil or
|
||||
;; a vector whose last element is the newline glyph.
|
||||
(let ((glyphs (butlast (append fci-saved-eol nil)))
|
||||
eol)
|
||||
(if glyphs
|
||||
(setq fci-newline [10]
|
||||
eol (vconcat glyphs))
|
||||
(setq fci-newline nil
|
||||
eol [32]))
|
||||
(aset buffer-display-table 10 fci-newline)
|
||||
(aset buffer-display-table fci-eol-char eol))
|
||||
(setq fci-display-table-processed t)))
|
||||
|
||||
(defun fci-set-local-vars ()
|
||||
"Set miscellaneous local variables when fci-mode is enabled."
|
||||
(unless fci-local-vars-set
|
||||
(when (and fci-handle-line-move-visual
|
||||
(boundp 'line-move-visual))
|
||||
(if (local-variable-p 'line-move-visual)
|
||||
(setq fci-line-move-visual-was-buffer-local t
|
||||
fci-saved-line-move-visual line-move-visual
|
||||
line-move-visual nil)
|
||||
(set (make-local-variable 'line-move-visual) nil)))
|
||||
(when fci-handle-truncate-lines
|
||||
(setq fci-saved-truncate-lines truncate-lines
|
||||
truncate-lines t))
|
||||
(setq fci-local-vars-set t)))
|
||||
|
||||
(defun fci-make-rule-string ()
|
||||
"Return a string for drawing the fill-column rule."
|
||||
(let ((color (or fci-rule-character-color
|
||||
fci-rule-color)))
|
||||
;; Make sure we don't inherit weight or slant from font-lock.
|
||||
(propertize (char-to-string fci-rule-character)
|
||||
'face `(:foreground ,color :weight normal :slant normal))))
|
||||
|
||||
(defun fci-make-img-descriptor ()
|
||||
"Make an image descriptor for the fill-column rule."
|
||||
(unless (or (= 0 fci-char-width)
|
||||
fci-always-use-textual-rule)
|
||||
;; No point passing width, height, color etc. directly to the image
|
||||
;; functions: those variables have either global or buffer-local
|
||||
;; scope, so the image-generating functions can access them directly.
|
||||
(if (eq fci-rule-image-format 'xpm)
|
||||
(fci-make-xpm-img)
|
||||
(fci-make-pbm-img))))
|
||||
|
||||
(defun fci-get-frame-dimens ()
|
||||
"Determine the frame character height and width.
|
||||
|
||||
If the selected frame cannot display images, use the character
|
||||
height and width of the first graphic frame in the frame list
|
||||
displaying the current buffer. (This fallback behavior is just a
|
||||
rough heuristic.)"
|
||||
(let ((frame (catch 'found-graphic
|
||||
(if (display-images-p)
|
||||
(selected-frame)
|
||||
(dolist (win (fci-get-buffer-windows t))
|
||||
(when (display-images-p (window-frame win))
|
||||
(throw 'found-graphic (window-frame win))))))))
|
||||
(setq fci-char-width (frame-char-width frame)
|
||||
fci-char-height (frame-char-height frame))))
|
||||
|
||||
(defmacro fci-with-rule-parameters (&rest body)
|
||||
"Define various quantites used in generating rule image descriptors."
|
||||
(declare (indent defun))
|
||||
`(let* ((height-str (number-to-string fci-char-height))
|
||||
(width-str (number-to-string fci-char-width))
|
||||
(rule-width (min fci-rule-width fci-char-width))
|
||||
(hmargin (/ (- fci-char-width rule-width) 2.0))
|
||||
(left-margin (floor hmargin))
|
||||
(right-margin (ceiling hmargin))
|
||||
(segment-ratio (if fci-rule-use-dashes fci-dash-pattern 1))
|
||||
(segment-ratio-coerced (min 1 (max 0 segment-ratio)))
|
||||
(segment-length (round (* segment-ratio-coerced fci-char-height)))
|
||||
(vmargin (/ (- fci-char-height segment-length) 2.0))
|
||||
(top-margin (floor vmargin))
|
||||
(bottom-margin (ceiling vmargin)))
|
||||
,@body))
|
||||
|
||||
(defun fci-mapconcat (sep &rest lists)
|
||||
"Concatenate the strings in LISTS, using SEP as separator."
|
||||
(mapconcat #'identity (apply 'nconc lists) sep))
|
||||
|
||||
(defun fci-make-pbm-img ()
|
||||
"Return an image descriptor for the fill-column rule in PBM format."
|
||||
(fci-with-rule-parameters
|
||||
(let* ((magic-number "P1\n")
|
||||
(dimens (concat width-str " " height-str "\n"))
|
||||
(on-pixels (fci-mapconcat " "
|
||||
(make-list left-margin "0")
|
||||
(make-list rule-width "1")
|
||||
(make-list right-margin "0")))
|
||||
(off-pixels (fci-mapconcat " " (make-list fci-char-width "0")))
|
||||
(raster (fci-mapconcat "\n"
|
||||
(make-list top-margin off-pixels)
|
||||
(make-list segment-length on-pixels)
|
||||
(make-list bottom-margin off-pixels)))
|
||||
(data (concat magic-number dimens raster)))
|
||||
`(image :type pbm
|
||||
:data ,data
|
||||
:mask heuristic
|
||||
:foreground ,fci-rule-color
|
||||
:ascent center))))
|
||||
|
||||
(defun fci-make-xpm-img ()
|
||||
"Return an image descriptor for the fill-column rule in XPM format."
|
||||
(fci-with-rule-parameters
|
||||
(let* ((identifier "/* XPM */\nstatic char *rule[] = {")
|
||||
(dimens (concat "\"" width-str " " height-str " 2 1\","))
|
||||
(color-spec (concat "\"1 c " fci-rule-color "\",\"0 c None\","))
|
||||
(on-pixels (concat "\""
|
||||
(make-string left-margin ?0)
|
||||
(make-string rule-width ?1)
|
||||
(make-string right-margin ?0)
|
||||
"\","))
|
||||
(off-pixels (concat "\"" (make-string fci-char-width ?0) "\","))
|
||||
(raster (fci-mapconcat ""
|
||||
(make-list top-margin off-pixels)
|
||||
(make-list segment-length on-pixels)
|
||||
(make-list bottom-margin off-pixels)))
|
||||
(end "};")
|
||||
(data (concat identifier dimens color-spec raster end)))
|
||||
`(image :type xpm
|
||||
:data ,data
|
||||
:mask heuristic
|
||||
:ascent center))))
|
||||
|
||||
(defun fci-make-overlay-strings ()
|
||||
"Generate the overlay strings used to display the fill-column rule."
|
||||
(let* ((str (fci-make-rule-string))
|
||||
(img (fci-make-img-descriptor))
|
||||
(blank-str (char-to-string fci-blank-char))
|
||||
(eol-str (char-to-string fci-eol-char))
|
||||
(end-cap (propertize blank-str 'display '(space :width 0)))
|
||||
(pre-or-post-eol (propertize eol-str
|
||||
'cursor t
|
||||
'display (propertize eol-str 'cursor t)))
|
||||
(pre-padding (propertize blank-str 'display fci-padding-display))
|
||||
(pre-rule (fci-rule-display blank-str img str t))
|
||||
(at-rule (fci-rule-display blank-str img str fci-newline))
|
||||
(at-eol (if fci-newline pre-or-post-eol "")))
|
||||
(setq fci-pre-limit-string (concat pre-or-post-eol pre-padding pre-rule)
|
||||
fci-at-limit-string (concat at-eol at-rule)
|
||||
fci-post-limit-string (concat pre-or-post-eol end-cap))))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Disabling
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
(defun fci-restore-local-vars ()
|
||||
"Restore miscellaneous local variables when fci-mode is disabled."
|
||||
(when fci-local-vars-set
|
||||
(when (and fci-handle-line-move-visual
|
||||
(boundp 'line-move-visual))
|
||||
(if fci-line-move-visual-was-buffer-local
|
||||
(setq line-move-visual fci-saved-line-move-visual)
|
||||
(kill-local-variable 'line-move-visual)))
|
||||
(when fci-handle-truncate-lines
|
||||
(setq truncate-lines fci-saved-truncate-lines))))
|
||||
|
||||
(defun fci-restore-display-table ()
|
||||
"Restore the buffer display table when fci-mode is disabled."
|
||||
(when (and buffer-display-table
|
||||
fci-display-table-processed)
|
||||
(aset buffer-display-table 10 fci-saved-eol)
|
||||
;; Don't set buffer-display-table to nil even if we created the display
|
||||
;; table; only do so if nothing else has changed it.
|
||||
(when (and fci-made-display-table
|
||||
(equal buffer-display-table (make-display-table)))
|
||||
(setq buffer-display-table nil))))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Drawing and Erasing
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
(defun fci-get-overlays-region (start end)
|
||||
"Return all overlays between START and END displaying the fill-column rule."
|
||||
(delq nil (mapcar #'(lambda (o) (if (overlay-get o 'fci) o))
|
||||
(overlays-in start end))))
|
||||
|
||||
(defun fci-delete-overlays-region (start end)
|
||||
"Delete overlays displaying the fill-column rule between START and END."
|
||||
(mapc #'(lambda (o) (if (overlay-get o 'fci) (delete-overlay o)))
|
||||
(overlays-in start end)))
|
||||
|
||||
(defun fci-delete-overlays-buffer ()
|
||||
"Delete all overlays displaying the fill-column rule in the current buffer."
|
||||
(save-restriction
|
||||
(widen)
|
||||
(fci-delete-overlays-region (point-min) (point-max))))
|
||||
|
||||
(defsubst fci-posn-visible-p (posn ranges)
|
||||
"Return true if POSN falls within an interval in RANGES."
|
||||
(memq t (mapcar #'(lambda (range) (and (<= (car range) posn)
|
||||
(< posn (cdr range))))
|
||||
ranges)))
|
||||
|
||||
(defsubst fci-get-visible-ranges ()
|
||||
"Return the window start and end for each window on the current buffer."
|
||||
(mapcar #'(lambda (w) (cons (window-start w) (window-end w 'updated)))
|
||||
(fci-get-buffer-windows t)))
|
||||
|
||||
(defun fci-delete-unneeded ()
|
||||
"Erase the fill-column rule at buffer positions not visible in any window."
|
||||
(let ((olays (fci-get-overlays-region (point-min) (point-max)))
|
||||
(ranges (fci-get-visible-ranges)))
|
||||
(dolist (o olays)
|
||||
(unless (fci-posn-visible-p (overlay-start o) ranges)
|
||||
(delete-overlay o)))))
|
||||
|
||||
;; It would be slightly faster to run this backwards from END to START, but
|
||||
;; only if we maintained the overlay center at an early position in the
|
||||
;; buffer. Since other packages that use overlays typically place them while
|
||||
;; traversing the buffer in a forward direction, that would be a bad idea.
|
||||
(defun fci-put-overlays-region (start end)
|
||||
"Place overlays displaying the fill-column rule between START and END."
|
||||
(goto-char start)
|
||||
(let (o cc)
|
||||
(while (search-forward "\n" end t)
|
||||
(goto-char (match-beginning 0))
|
||||
(setq cc (current-column)
|
||||
o (make-overlay (match-beginning 0) (match-beginning 0)))
|
||||
(overlay-put o 'fci t)
|
||||
(cond
|
||||
((< cc fci-limit)
|
||||
(overlay-put o 'after-string fci-pre-limit-string))
|
||||
((> cc fci-limit)
|
||||
(overlay-put o 'after-string fci-post-limit-string))
|
||||
(t
|
||||
(overlay-put o 'after-string fci-at-limit-string)))
|
||||
(goto-char (match-end 0)))))
|
||||
|
||||
(defun fci-redraw-region (start end _ignored)
|
||||
"Erase and redraw the fill-column rule between START and END."
|
||||
(save-match-data
|
||||
(save-excursion
|
||||
(let ((inhibit-point-motion-hooks t))
|
||||
(goto-char end)
|
||||
(setq end (line-beginning-position 2))
|
||||
(fci-delete-overlays-region start end)
|
||||
(fci-put-overlays-region start end)))))
|
||||
|
||||
(defun fci-redraw-window (win &optional start)
|
||||
"Redraw the fill-column rule in WIN starting from START."
|
||||
(fci-redraw-region (or start (window-start win)) (window-end win t) 'ignored))
|
||||
|
||||
;; This doesn't determine the strictly minimum amount by which the rule needs
|
||||
;; to be extended, but the amount used is always sufficient, and determining
|
||||
;; the genuine minimum is more expensive than doing the extra drawing.
|
||||
(defun fci-extend-rule-for-deletion (start end)
|
||||
"Extend the fill-column rule after a deletion that spans newlines."
|
||||
(unless (= start end)
|
||||
(let ((delenda (fci-get-overlays-region start end)))
|
||||
(when delenda
|
||||
(let ((lossage (1+ (length delenda)))
|
||||
(max-end 0)
|
||||
win-end)
|
||||
(mapc #'delete-overlay delenda)
|
||||
(dolist (win (fci-get-buffer-windows t))
|
||||
;; Do not ask for an updated value of window-end.
|
||||
(setq win-end (window-end win))
|
||||
(when (and (< 0 (- (min win-end end)
|
||||
(max (window-start win) start)))
|
||||
(< max-end win-end))
|
||||
(setq max-end win-end)))
|
||||
(unless (= max-end (point-max))
|
||||
(fci-redraw-region max-end
|
||||
(save-excursion
|
||||
(goto-char max-end)
|
||||
(line-beginning-position lossage))
|
||||
nil)))))))
|
||||
|
||||
(defun fci-update-window-for-scroll (win start)
|
||||
"Redraw the fill-column rule in WIN after it has been been scrolled."
|
||||
(fci-delete-unneeded)
|
||||
(fci-redraw-window win start))
|
||||
|
||||
(defun fci-update-all-windows (&optional all-frames)
|
||||
"Redraw the fill-column rule in all windows showing the current buffer."
|
||||
(dolist (win (fci-get-buffer-windows all-frames))
|
||||
(fci-redraw-window win)))
|
||||
|
||||
(defun fci-redraw-frame ()
|
||||
"Redraw the fill-column rule in all windows on the selected frame."
|
||||
(let* ((wins (window-list (selected-frame) 'no-minibuf))
|
||||
(bufs (delete-dups (mapcar #'window-buffer wins))))
|
||||
(dolist (buf bufs)
|
||||
(with-current-buffer buf
|
||||
(when fci-mode
|
||||
(fci-delete-unneeded)
|
||||
(fci-update-all-windows))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; Workarounds
|
||||
;;; ---------------------------------------------------------------------
|
||||
|
||||
;; This in placed in post-command-hook and does four things:
|
||||
;; 1. If the display table has been deleted or something has changed the
|
||||
;; display table for newline chars, we regenerate overlay strings after
|
||||
;; reprocessing the display table.
|
||||
;; 2. If the default char width or height has changed, we regenerate the rule
|
||||
;; image. (This handles both font changes and also cases where we
|
||||
;; activate the mode while displaying on a char terminal then subsequently
|
||||
;; display the buffer on a window frame.)
|
||||
;; 3. If the value of `tab-width' or `fill-column' has changed, we reset the
|
||||
;; rule.
|
||||
;; 4. Cursor properties are ignored when they're out of sight because of
|
||||
;; horizontal scrolling. We detect such situations and force a return
|
||||
;; from hscrolling to bring our requested cursor position back into view.
|
||||
;; These are all fast tests, so despite the large remit this function
|
||||
;; shouldn't noticeably affect editing speed.
|
||||
(defun fci-post-command-check ()
|
||||
"This function is a gross hack."
|
||||
(cond
|
||||
((not (and buffer-display-table
|
||||
(equal (aref buffer-display-table 10) fci-newline)))
|
||||
(setq fci-display-table-processed nil)
|
||||
(fci-mode 1))
|
||||
((and (< 1 (frame-char-width))
|
||||
(not fci-always-use-textual-rule)
|
||||
(not (and (= (frame-char-width) fci-char-width)
|
||||
(= (frame-char-height) fci-char-height))))
|
||||
(fci-mode 1))
|
||||
((not (and (= (or fci-rule-column fill-column) fci-column)
|
||||
(= tab-width fci-tab-width)))
|
||||
(fci-mode 1))
|
||||
((and (< 0 (window-hscroll))
|
||||
auto-hscroll-mode
|
||||
(<= (current-column) (window-hscroll)))
|
||||
;; Fix me: Rather than setting hscroll to 0, this should reproduce the
|
||||
;; relevant part of the auto-hscrolling algorithm. Most people won't
|
||||
;; notice the difference in behavior, though.
|
||||
(set-window-hscroll (selected-window) 0))))
|
||||
|
||||
(provide 'fill-column-indicator)
|
||||
|
||||
;; Local Variables:
|
||||
;; indent-tabs-mode: nil
|
||||
;; End:
|
||||
;;; fill-column-indicator.el ends here
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
128
26.3/develop/ghub-20200425.2233/buck.el
Normal file
128
26.3/develop/ghub-20200425.2233/buck.el
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
;;; buck.el --- minuscule client library for the Bitbucket API -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2016-2020 Jonas Bernoulli
|
||||
|
||||
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||
;; Homepage: https://github.com/magit/ghub
|
||||
;; Keywords: tools
|
||||
|
||||
;; 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.
|
||||
|
||||
;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Buck is a library that provides basic support for using the Bitbucket API
|
||||
;; from Emacs packages. It abstracts access to API resources using only
|
||||
;; a handful of functions that are not resource-specific.
|
||||
|
||||
;; This library is implemented on top of Ghub. Unlike Ghub, Buck does
|
||||
;; not support the guided creation of tokens because Bitbucket lacks the
|
||||
;; features that would be necessary to implement that. Users have to
|
||||
;; create tokens through the web interface.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ghub)
|
||||
|
||||
(defconst buck-default-host "api.bitbucket.org/2.0"
|
||||
"The default host that is used if `buck.host' is not set.")
|
||||
|
||||
;; HEAD and PATCH are not supported according to
|
||||
;; https://developer.atlassian.com/bitbucket/api/2/reference/meta/uri-uuid
|
||||
|
||||
(cl-defun buck-get (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `GET' request for RESOURCE, with optional query PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"GET\" as METHOD
|
||||
and `bitbucket' as FORGE."
|
||||
(ghub-request "GET" resource params :forge 'bitbucket
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun buck-put (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PUT' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PUT\" as METHOD
|
||||
and `bitbucket' as FORGE."
|
||||
(ghub-request "PUT" resource params :forge 'bitbucket
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun buck-post (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `POST' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"POST\" as METHOD
|
||||
and `bitbucket' as FORGE."
|
||||
(ghub-request "POST" resource params :forge 'bitbucket
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun buck-delete (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `DELETE' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"DELETE\" as METHOD
|
||||
and `bitbucket' as FORGE."
|
||||
(ghub-request "DELETE" resource params :forge 'bitbucket
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun buck-request (method resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a request for RESOURCE and return the response body.
|
||||
Like calling `ghub-request' (which see) with `bitbucket' as FORGE."
|
||||
(ghub-request method resource params :forge 'bitbucket
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun buck-repository-id (owner name &key username auth host)
|
||||
"Return the id of the repository specified by OWNER, NAME and HOST."
|
||||
(substring (cdr (assq 'uuid
|
||||
(buck-get (format "/repositories/%s/%s" owner name)
|
||||
nil
|
||||
:username username :auth auth :host host)))
|
||||
1 -1))
|
||||
|
||||
;;; _
|
||||
(provide 'buck)
|
||||
;;; buck.el ends here
|
||||
BIN
26.3/develop/ghub-20200425.2233/buck.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/buck.elc
Normal file
Binary file not shown.
18
26.3/develop/ghub-20200425.2233/dir
Normal file
18
26.3/develop/ghub-20200425.2233/dir
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
This is the file .../info/dir, which contains the
|
||||
topmost node of the Info hierarchy, called (dir)Top.
|
||||
The first time you invoke Info you start off looking at this node.
|
||||
|
||||
File: dir, Node: Top This is the top of the INFO tree
|
||||
|
||||
This (the Directory node) gives a menu of major topics.
|
||||
Typing "q" exits, "H" lists all Info commands, "d" returns here,
|
||||
"h" gives a primer for first-timers,
|
||||
"mEmacs<Return>" visits the Emacs manual, etc.
|
||||
|
||||
In Emacs, you can click mouse button 2 on a menu item or cross reference
|
||||
to select it.
|
||||
|
||||
* Menu:
|
||||
|
||||
Emacs
|
||||
* Ghub: (ghub). Minuscule client library for the Github API.
|
||||
97
26.3/develop/ghub-20200425.2233/ghub-autoloads.el
Normal file
97
26.3/develop/ghub-20200425.2233/ghub-autoloads.el
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
;;; ghub-autoloads.el --- automatically extracted autoloads
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(add-to-list 'load-path (directory-file-name
|
||||
(or (file-name-directory #$) (car load-path))))
|
||||
|
||||
|
||||
;;;### (autoloads nil "buck" "buck.el" (0 0 0 0))
|
||||
;;; Generated autoloads from buck.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "buck" '("buck-default-host")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "ghub" "ghub.el" (0 0 0 0))
|
||||
;;; Generated autoloads from ghub.el
|
||||
|
||||
(autoload 'ghub-create-token "ghub" "\
|
||||
Create, store and return a new token.
|
||||
|
||||
HOST is the Github instance, usually \"api.github.com\".
|
||||
USERNAME is the name of a user on that instance.
|
||||
PACKAGE is the package that will use the token.
|
||||
SCOPES are the scopes the token is given access to.
|
||||
|
||||
\(fn HOST USERNAME PACKAGE SCOPES)" t nil)
|
||||
|
||||
(autoload 'ghub-token-scopes "ghub" "\
|
||||
Return and echo the scopes of the specified token.
|
||||
This is intended for debugging purposes only. The user
|
||||
has to provide several values including their password.
|
||||
|
||||
\(fn HOST USERNAME PACKAGE)" t nil)
|
||||
|
||||
(autoload 'ghub-clear-caches "ghub" "\
|
||||
Clear all caches that might negatively affect Ghub.
|
||||
|
||||
If a library that is used by Ghub caches incorrect information
|
||||
such as a mistyped password, then that can prevent Ghub from
|
||||
asking the user for the correct information again.
|
||||
|
||||
Set `url-http-real-basic-auth-storage' to nil
|
||||
and call `auth-source-forget+'.
|
||||
|
||||
\(fn)" t nil)
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ghub" '("auth-source-netrc-parse-next-interesting@save-match-data" "ghub-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "ghub-graphql" "ghub-graphql.el" (0 0 0 0))
|
||||
;;; Generated autoloads from ghub-graphql.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ghub-graphql" '("ghub-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "glab" "glab.el" (0 0 0 0))
|
||||
;;; Generated autoloads from glab.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "glab" '("glab-default-host")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "gogs" "gogs.el" (0 0 0 0))
|
||||
;;; Generated autoloads from gogs.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gogs" '("gogs-default-host")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "gsexp" "gsexp.el" (0 0 0 0))
|
||||
;;; Generated autoloads from gsexp.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gsexp" '("gsexp-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil "gtea" "gtea.el" (0 0 0 0))
|
||||
;;; Generated autoloads from gtea.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gtea" '("gtea-default-host")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("ghub-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
;; version-control: never
|
||||
;; no-byte-compile: t
|
||||
;; no-update-autoloads: t
|
||||
;; coding: utf-8
|
||||
;; End:
|
||||
;;; ghub-autoloads.el ends here
|
||||
460
26.3/develop/ghub-20200425.2233/ghub-graphql.el
Normal file
460
26.3/develop/ghub-20200425.2233/ghub-graphql.el
Normal file
|
|
@ -0,0 +1,460 @@
|
|||
;;; ghub-graphql.el --- access Github API using GrapthQL -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2016-2020 Jonas Bernoulli
|
||||
|
||||
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||
;; Homepage: https://github.com/magit/ghub
|
||||
|
||||
;; 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.
|
||||
|
||||
;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ghub)
|
||||
(require 'gsexp)
|
||||
(require 'treepy)
|
||||
|
||||
(eval-when-compile
|
||||
(require 'subr-x))
|
||||
|
||||
;;; Api
|
||||
|
||||
(cl-defun ghub-graphql (graphql &optional variables
|
||||
&key username auth host
|
||||
silent
|
||||
callback errorback value extra)
|
||||
"Make a GraphQL request using GRAPHQL and VARIABLES.
|
||||
Return the response as a JSON-like alist. Even if the response
|
||||
contains `errors', do not raise an error. GRAPHQL is a GraphQL
|
||||
string. VARIABLES is a JSON-like alist. The other arguments
|
||||
behave as for `ghub-request' (which see)."
|
||||
(cl-assert (stringp graphql))
|
||||
(cl-assert (not (stringp variables)))
|
||||
(ghub-request "POST" "/graphql" nil :payload
|
||||
(json-encode `(("query" . ,graphql)
|
||||
,@(and variables `(("variables" ,@variables)))))
|
||||
:silent silent
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback
|
||||
:extra extra :value value))
|
||||
|
||||
(cl-defun ghub-graphql-rate-limit (&key username auth host)
|
||||
"Return rate limit information."
|
||||
(let-alist (ghub-graphql
|
||||
"query { rateLimit { limit cost remaining resetAt }}"
|
||||
nil :username username :auth auth :host host)
|
||||
.data.rateLimit))
|
||||
|
||||
(cl-defun ghub--repository-id (owner name &key username auth host)
|
||||
"Return the id of the repository specified by OWNER, NAME and HOST."
|
||||
(let-alist (ghub-graphql
|
||||
"query ($owner:String!, $name:String!) {
|
||||
repository(owner:$owner, name:$name) { id }
|
||||
}"
|
||||
`((owner . ,owner)
|
||||
(name . ,name))
|
||||
:username username :auth auth :host host)
|
||||
.data.repository.id))
|
||||
|
||||
;;; Api (drafts)
|
||||
|
||||
(defconst ghub-fetch-repository
|
||||
'(query
|
||||
(repository
|
||||
[(owner $owner String!)
|
||||
(name $name String!)]
|
||||
name
|
||||
id
|
||||
createdAt
|
||||
updatedAt
|
||||
nameWithOwner
|
||||
(parent nameWithOwner)
|
||||
description
|
||||
homepageUrl
|
||||
(defaultBranchRef name)
|
||||
isArchived
|
||||
isFork
|
||||
isLocked
|
||||
isMirror
|
||||
isPrivate
|
||||
hasIssuesEnabled
|
||||
hasWikiEnabled
|
||||
(licenseInfo name)
|
||||
(stargazers totalCount)
|
||||
(watchers totalCount)
|
||||
(assignableUsers [(:edges t)]
|
||||
id
|
||||
login
|
||||
name)
|
||||
(issues [(:edges t)
|
||||
(:singular issue number)
|
||||
(orderBy ((field UPDATED_AT) (direction DESC)))]
|
||||
number
|
||||
state
|
||||
(author login)
|
||||
title
|
||||
createdAt
|
||||
updatedAt
|
||||
closedAt
|
||||
locked
|
||||
(milestone id)
|
||||
body
|
||||
(assignees [(:edges t)]
|
||||
id)
|
||||
(comments [(:edges t)]
|
||||
databaseId
|
||||
(author login)
|
||||
createdAt
|
||||
updatedAt
|
||||
body)
|
||||
(labels [(:edges t)]
|
||||
id))
|
||||
(labels [(:edges t)
|
||||
(:singular label id)]
|
||||
id
|
||||
name
|
||||
color
|
||||
description)
|
||||
(pullRequests [(:edges t)
|
||||
(:singular pullRequest number)
|
||||
(orderBy ((field UPDATED_AT) (direction DESC)))]
|
||||
number
|
||||
state
|
||||
(author login)
|
||||
title
|
||||
createdAt
|
||||
updatedAt
|
||||
closedAt
|
||||
mergedAt
|
||||
locked
|
||||
maintainerCanModify
|
||||
isCrossRepository
|
||||
(milestone id)
|
||||
body
|
||||
(baseRef name
|
||||
(repository nameWithOwner))
|
||||
(headRef name
|
||||
(repository (owner login)
|
||||
nameWithOwner))
|
||||
(assignees [(:edges t)]
|
||||
id)
|
||||
(reviewRequests [(:edges t)]
|
||||
(requestedReviewer "... on User { id }\n"))
|
||||
(comments [(:edges t)]
|
||||
databaseId
|
||||
(author login)
|
||||
createdAt
|
||||
updatedAt
|
||||
body)
|
||||
(labels [(:edges t)]
|
||||
id)))))
|
||||
|
||||
(cl-defun ghub-fetch-repository (owner name callback
|
||||
&optional until
|
||||
&key username auth host forge errorback)
|
||||
"Asynchronously fetch forge data about the specified repository.
|
||||
Once all data has been collected, CALLBACK is called with the
|
||||
data as the only argument."
|
||||
(ghub--graphql-vacuum ghub-fetch-repository
|
||||
`((owner . ,owner)
|
||||
(name . ,name))
|
||||
callback until
|
||||
:narrow '(repository)
|
||||
:username username
|
||||
:auth auth
|
||||
:host host
|
||||
:forge forge
|
||||
:errorback errorback))
|
||||
|
||||
(cl-defun ghub-fetch-issue (owner name number callback
|
||||
&optional until
|
||||
&key username auth host forge errorback)
|
||||
"Asynchronously fetch forge data about the specified issue.
|
||||
Once all data has been collected, CALLBACK is called with the
|
||||
data as the only argument."
|
||||
(ghub--graphql-vacuum (ghub--graphql-prepare-query
|
||||
ghub-fetch-repository
|
||||
`(repository issues (issue . ,number)))
|
||||
`((owner . ,owner)
|
||||
(name . ,name))
|
||||
callback until
|
||||
:narrow '(repository issue)
|
||||
:username username
|
||||
:auth auth
|
||||
:host host
|
||||
:forge forge
|
||||
:errorback errorback))
|
||||
|
||||
(cl-defun ghub-fetch-pullreq (owner name number callback
|
||||
&optional until
|
||||
&key username auth host forge errorback)
|
||||
"Asynchronously fetch forge data about the specified pull-request.
|
||||
Once all data has been collected, CALLBACK is called with the
|
||||
data as the only argument."
|
||||
(ghub--graphql-vacuum (ghub--graphql-prepare-query
|
||||
ghub-fetch-repository
|
||||
`(repository pullRequests (pullRequest . ,number)))
|
||||
`((owner . ,owner)
|
||||
(name . ,name))
|
||||
callback until
|
||||
:narrow '(repository pullRequest)
|
||||
:username username
|
||||
:auth auth
|
||||
:host host
|
||||
:forge forge
|
||||
:errorback errorback))
|
||||
|
||||
;;; Internal
|
||||
|
||||
(cl-defstruct (ghub--graphql-req
|
||||
(:include ghub--req)
|
||||
(:constructor ghub--make-graphql-req)
|
||||
(:copier nil))
|
||||
(query nil :read-only t)
|
||||
(query-str nil :read-only nil)
|
||||
(variables nil :read-only t)
|
||||
(until nil :read-only t)
|
||||
(buffer nil :read-only t)
|
||||
(pages 0 :read-only nil))
|
||||
|
||||
(cl-defun ghub--graphql-vacuum (query variables callback
|
||||
&optional until
|
||||
&key narrow username auth host forge
|
||||
errorback)
|
||||
"Make a GraphQL request using QUERY and VARIABLES.
|
||||
See Info node `(ghub)GraphQL Support'."
|
||||
(unless host
|
||||
(setq host (ghub--host forge)))
|
||||
(unless (or username (stringp auth) (eq auth 'none))
|
||||
(setq username (ghub--username host forge)))
|
||||
(ghub--graphql-retrieve
|
||||
(ghub--make-graphql-req
|
||||
:url (url-generic-parse-url
|
||||
(format "https://%s/graphql"
|
||||
(if (string-suffix-p "/v3" host)
|
||||
(substring host 0 -3)
|
||||
host)))
|
||||
:method "POST"
|
||||
:headers (ghub--headers nil host auth username forge)
|
||||
:handler 'ghub--graphql-handle-response
|
||||
:query query
|
||||
:variables variables
|
||||
:until until
|
||||
:buffer (current-buffer)
|
||||
:callback (let ((buf (current-buffer)))
|
||||
(if narrow
|
||||
(lambda (data)
|
||||
(let ((path narrow) key)
|
||||
(while (setq key (pop path))
|
||||
(setq data (cdr (assq key data)))))
|
||||
(ghub--graphql-set-mode-line buf nil)
|
||||
(funcall callback data))
|
||||
(lambda (data)
|
||||
(ghub--graphql-set-mode-line buf nil)
|
||||
(funcall callback data))))
|
||||
:errorback errorback)))
|
||||
|
||||
(cl-defun ghub--graphql-retrieve (req &optional lineage cursor)
|
||||
(let ((p (cl-incf (ghub--graphql-req-pages req))))
|
||||
(when (> p 1)
|
||||
(ghub--graphql-set-mode-line req "Fetching page %s" p)))
|
||||
(setf (ghub--graphql-req-query-str req)
|
||||
(gsexp-encode
|
||||
(ghub--graphql-prepare-query
|
||||
(ghub--graphql-req-query req)
|
||||
lineage cursor)))
|
||||
(ghub--retrieve
|
||||
(let ((json-false nil))
|
||||
(ghub--encode-payload
|
||||
`((query . ,(ghub--graphql-req-query-str req))
|
||||
(variables . ,(ghub--graphql-req-variables req)))))
|
||||
req))
|
||||
|
||||
(defun ghub--graphql-prepare-query (query &optional lineage cursor)
|
||||
(when lineage
|
||||
(setq query (ghub--graphql-narrow-query query lineage cursor)))
|
||||
(let ((loc (ghub--alist-zip query))
|
||||
variables)
|
||||
(cl-block nil
|
||||
(while t
|
||||
(let ((node (treepy-node loc)))
|
||||
(when (vectorp node)
|
||||
(let ((alist (cl-coerce node 'list))
|
||||
vars)
|
||||
(when (cadr (assq :edges alist))
|
||||
(push (list 'first 100) vars)
|
||||
(setq loc (treepy-up loc))
|
||||
(setq node (treepy-node loc))
|
||||
(setq loc (treepy-replace
|
||||
loc `(,(car node)
|
||||
,(cadr node)
|
||||
(pageInfo endCursor hasNextPage)
|
||||
(edges (node ,@(cddr node))))))
|
||||
(setq loc (treepy-down loc))
|
||||
(setq loc (treepy-next loc)))
|
||||
(dolist (elt alist)
|
||||
(cond ((keywordp (car elt)))
|
||||
((= (length elt) 3)
|
||||
(push (list (nth 0 elt)
|
||||
(nth 1 elt)) vars)
|
||||
(push (list (nth 1 elt)
|
||||
(nth 2 elt)) variables))
|
||||
((= (length elt) 2)
|
||||
(push elt vars))))
|
||||
(setq loc (treepy-replace loc (vconcat (nreverse vars)))))))
|
||||
(if (treepy-end-p loc)
|
||||
(let ((node (copy-sequence (treepy-node loc))))
|
||||
(when variables
|
||||
(push (cl-coerce variables 'vector)
|
||||
(cdr node)))
|
||||
(cl-return node))
|
||||
(setq loc (treepy-next loc)))))))
|
||||
|
||||
(defun ghub--graphql-handle-response (status req)
|
||||
(let ((buffer (current-buffer)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(set-buffer-multibyte t)
|
||||
(let* ((headers (ghub--handle-response-headers status req))
|
||||
(payload (ghub--handle-response-payload req))
|
||||
(payload (ghub--handle-response-error status payload req))
|
||||
(err (plist-get status :error))
|
||||
(errors (cdr (assq 'errors payload)))
|
||||
(errors (and errors (cons 'ghub-graphql-error errors))))
|
||||
(if (or err errors)
|
||||
(if-let ((errorback (ghub--req-errorback req)))
|
||||
(funcall errorback (or err errors) headers status req)
|
||||
(ghub--signal-error (or err errors)))
|
||||
(ghub--graphql-walk-response req (assq 'data payload)))))
|
||||
(when (buffer-live-p buffer)
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(defun ghub--graphql-walk-response (req data)
|
||||
(let* ((loc (ghub--req-value req))
|
||||
(loc (if (not loc)
|
||||
(ghub--alist-zip data)
|
||||
(setq data (ghub--graphql-narrow-data
|
||||
data (ghub--graphql-lineage loc)))
|
||||
(setf (alist-get 'edges data)
|
||||
(append (alist-get 'edges (treepy-node loc))
|
||||
(or (alist-get 'edges data)
|
||||
(error "BUG: Expected new nodes"))))
|
||||
(treepy-replace loc data))))
|
||||
(cl-block nil
|
||||
(while t
|
||||
(when (eq (car-safe (treepy-node loc)) 'edges)
|
||||
(setq loc (treepy-up loc))
|
||||
(pcase-let ((`(,key . ,val) (treepy-node loc)))
|
||||
(let-alist val
|
||||
(let* ((cursor (and .pageInfo.hasNextPage
|
||||
.pageInfo.endCursor))
|
||||
(until (cdr (assq (intern (format "%s-until" key))
|
||||
(ghub--graphql-req-until req))))
|
||||
(nodes (mapcar #'cdar .edges))
|
||||
(nodes (if until
|
||||
(seq-take-while
|
||||
(lambda (node)
|
||||
(or (string> (cdr (assq 'updatedAt node))
|
||||
until)
|
||||
(setq cursor nil)))
|
||||
nodes)
|
||||
nodes)))
|
||||
(if cursor
|
||||
(progn
|
||||
(setf (ghub--req-value req) loc)
|
||||
(ghub--graphql-retrieve req
|
||||
(ghub--graphql-lineage loc)
|
||||
cursor)
|
||||
(cl-return))
|
||||
(setq loc (treepy-replace loc (cons key nodes))))))))
|
||||
(if (not (treepy-end-p loc))
|
||||
(setq loc (treepy-next loc))
|
||||
(funcall (ghub--req-callback req)
|
||||
(treepy-root loc))
|
||||
(cl-return))))))
|
||||
|
||||
(defun ghub--graphql-lineage (loc)
|
||||
(let (lineage)
|
||||
(while (treepy-up loc)
|
||||
(push (car (treepy-node loc)) lineage)
|
||||
(setq loc (treepy-up loc)))
|
||||
lineage))
|
||||
|
||||
(defun ghub--graphql-narrow-data (data lineage)
|
||||
(let (key)
|
||||
(while (setq key (pop lineage))
|
||||
(if (consp (car lineage))
|
||||
(progn (pop lineage)
|
||||
(setf data (cadr data)))
|
||||
(setq data (assq key (cdr data))))))
|
||||
data)
|
||||
|
||||
(defun ghub--graphql-narrow-query (query lineage cursor)
|
||||
(if (consp (car lineage))
|
||||
(let* ((child (cddr query))
|
||||
(alist (cl-coerce (cadr query) 'list))
|
||||
(single (cdr (assq :singular alist))))
|
||||
`(,(car single)
|
||||
,(vector (list (cadr single) (cdr (car lineage))))
|
||||
,@(if (cdr lineage)
|
||||
(ghub--graphql-narrow-query child (cdr lineage) cursor)
|
||||
child)))
|
||||
(let* ((child (or (assq (car lineage) (cdr query))
|
||||
;; Alias
|
||||
(cl-find-if (lambda (c)
|
||||
(eq (car-safe (car-safe c))
|
||||
(car lineage)))
|
||||
query)
|
||||
;; Edges
|
||||
(cl-find-if (lambda (c)
|
||||
(and (listp c)
|
||||
(vectorp (cadr c))
|
||||
(eq (cadr (assq :singular
|
||||
(cl-coerce (cadr c)
|
||||
'list)))
|
||||
(car lineage))))
|
||||
(cdr query))
|
||||
(error "BUG: Failed to narrow query")))
|
||||
(object (car query))
|
||||
(args (and (vectorp (cadr query))
|
||||
(cadr query))))
|
||||
`(,object
|
||||
,@(and args (list args))
|
||||
,(cond ((cdr lineage)
|
||||
(ghub--graphql-narrow-query child (cdr lineage) cursor))
|
||||
(cursor
|
||||
`(,(car child)
|
||||
,(vconcat `((after ,cursor))
|
||||
(cadr child))
|
||||
,@(cddr child)))
|
||||
(t
|
||||
child))))))
|
||||
|
||||
(defun ghub--alist-zip (root)
|
||||
(let ((branchp (lambda (elt) (and (listp elt) (listp (cdr elt)))))
|
||||
(make-node (lambda (_ children) children)))
|
||||
(treepy-zipper branchp #'identity make-node root)))
|
||||
|
||||
(defun ghub--graphql-set-mode-line (buf string &rest args)
|
||||
(when (ghub--graphql-req-p buf)
|
||||
(setq buf (ghub--graphql-req-buffer buf)))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf
|
||||
(setq mode-line-process
|
||||
(and string (concat " " (apply #'format string args))))
|
||||
(force-mode-line-update t))))
|
||||
|
||||
;;; _
|
||||
(provide 'ghub-graphql)
|
||||
;;; ghub-graphql.el ends here
|
||||
BIN
26.3/develop/ghub-20200425.2233/ghub-graphql.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/ghub-graphql.elc
Normal file
Binary file not shown.
7
26.3/develop/ghub-20200425.2233/ghub-pkg.el
Normal file
7
26.3/develop/ghub-20200425.2233/ghub-pkg.el
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(define-package "ghub" "20200425.2233" "Minuscule client libraries for Git forge APIs."
|
||||
'((emacs "25.1")
|
||||
(let-alist "1.0.5")
|
||||
(treepy "0.1.1")))
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
1083
26.3/develop/ghub-20200425.2233/ghub.el
Normal file
1083
26.3/develop/ghub-20200425.2233/ghub.el
Normal file
File diff suppressed because it is too large
Load diff
BIN
26.3/develop/ghub-20200425.2233/ghub.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/ghub.elc
Normal file
Binary file not shown.
1319
26.3/develop/ghub-20200425.2233/ghub.info
Normal file
1319
26.3/develop/ghub-20200425.2233/ghub.info
Normal file
File diff suppressed because it is too large
Load diff
155
26.3/develop/ghub-20200425.2233/glab.el
Normal file
155
26.3/develop/ghub-20200425.2233/glab.el
Normal file
|
|
@ -0,0 +1,155 @@
|
|||
;;; glab.el --- minuscule client library for the Gitlab API -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2016-2020 Jonas Bernoulli
|
||||
|
||||
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||
;; Homepage: https://github.com/magit/ghub
|
||||
;; Keywords: tools
|
||||
|
||||
;; 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.
|
||||
|
||||
;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Glab is a library that provides basic support for using the Gitlab API
|
||||
;; from Emacs packages. It abstracts access to API resources using only
|
||||
;; a handful of functions that are not resource-specific.
|
||||
|
||||
;; This library is implemented on top of Ghub. Unlike Ghub, Glab does
|
||||
;; not support the guided creation of tokens because Gitlab lacks the
|
||||
;; features that would be necessary to implement that. Users have to
|
||||
;; create tokens through the web interface.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ghub)
|
||||
|
||||
(defconst glab-default-host "gitlab.com/api/v4"
|
||||
"The default host that is used if `glab.host' is not set.")
|
||||
|
||||
(cl-defun glab-head (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `HEAD' request for RESOURCE, with optional query PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"HEAD\" as METHOD
|
||||
and `gitlab' as FORGE."
|
||||
(ghub-request "HEAD" resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-get (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `GET' request for RESOURCE, with optional query PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"GET\" as METHOD
|
||||
and `gitlab' as FORGE."
|
||||
(ghub-request "GET" resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-put (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PUT' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PUT\" as METHOD
|
||||
and `gitlab' as FORGE."
|
||||
(ghub-request "PUT" resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-post (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `POST' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"POST\" as METHOD
|
||||
and `gitlab' as FORGE."
|
||||
(ghub-request "POST" resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-patch (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PATCH' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PATCH\" as METHOD
|
||||
and `gitlab' as FORGE."
|
||||
(ghub-request "PATCH" resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-delete (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `DELETE' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"DELETE\" as METHOD
|
||||
and `gitlab' as FORGE."
|
||||
(ghub-request "DELETE" resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-request (method resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a request for RESOURCE and return the response body.
|
||||
Like calling `ghub-request' (which see) with `gitlab' as FORGE."
|
||||
(ghub-request method resource params :forge 'gitlab
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun glab-repository-id (owner name &key username auth host)
|
||||
"Return the id of the repository specified by OWNER, NAME and HOST."
|
||||
(number-to-string
|
||||
(cdr (assq 'id (glab-get (format "/projects/%s%%2F%s"
|
||||
(replace-regexp-in-string "/" "%2F" owner)
|
||||
name)
|
||||
nil :username username :auth auth :host host)))))
|
||||
|
||||
;;; _
|
||||
(provide 'glab)
|
||||
;;; glab.el ends here
|
||||
BIN
26.3/develop/ghub-20200425.2233/glab.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/glab.elc
Normal file
Binary file not shown.
140
26.3/develop/ghub-20200425.2233/gogs.el
Normal file
140
26.3/develop/ghub-20200425.2233/gogs.el
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
;;; gogs.el --- minuscule client library for the Gogs API -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2016-2020 Jonas Bernoulli
|
||||
|
||||
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||
;; Homepage: https://github.com/magit/ghub
|
||||
;; Keywords: tools
|
||||
|
||||
;; 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.
|
||||
|
||||
;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Gogs is a library that provides basic support for using the Gogs API
|
||||
;; from Emacs packages. It abstracts access to API resources using only
|
||||
;; a handful of functions that are not resource-specific.
|
||||
|
||||
;; This library is implemented on top of Ghub. Unlike Ghub, Gogs does
|
||||
;; not support the guided creation of tokens because Gogs lacks the
|
||||
;; features that would be necessary to implement that. Users have to
|
||||
;; create tokens through the web interface.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ghub)
|
||||
|
||||
(defconst gogs-default-host "localhost:3000/api/v1"
|
||||
"The default Gogs host.")
|
||||
|
||||
;; HEAD does not appear to be supported.
|
||||
|
||||
(cl-defun gogs-get (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `GET' request for RESOURCE, with optional query PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"GET\" as METHOD
|
||||
and `gogs' as FORGE."
|
||||
(ghub-request "GET" resource params :forge 'gogs
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gogs-put (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PUT' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PUT\" as METHOD
|
||||
and `gogs' as FORGE."
|
||||
(ghub-request "PUT" resource params :forge 'gogs
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gogs-post (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `POST' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"POST\" as METHOD
|
||||
and `gogs' as FORGE."
|
||||
(ghub-request "POST" resource params :forge 'gogs
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gogs-patch (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PATCH' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PATCH\" as METHOD
|
||||
and `gogs' as FORGE."
|
||||
(ghub-request "PATCH" resource params :forge 'gogs
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gogs-delete (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `DELETE' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"DELETE\" as METHOD
|
||||
and `gogs' as FORGE."
|
||||
(ghub-request "DELETE" resource params :forge 'gogs
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gogs-request (method resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a request for RESOURCE and return the response body.
|
||||
Like calling `ghub-request' (which see) with `gogs' as FORGE."
|
||||
(ghub-request method resource params :forge 'gogs
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gogs-repository-id (owner name &key username auth host)
|
||||
"Return the id of the repository specified by OWNER, NAME and HOST."
|
||||
(number-to-string
|
||||
(cdr (assq 'id (gogs-get (format "/repos/%s/%s" owner name)
|
||||
nil :username username :auth auth :host host)))))
|
||||
|
||||
;;; _
|
||||
(provide 'gogs)
|
||||
;;; gogs.el ends here
|
||||
BIN
26.3/develop/ghub-20200425.2233/gogs.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/gogs.elc
Normal file
Binary file not shown.
94
26.3/develop/ghub-20200425.2233/gsexp.el
Normal file
94
26.3/develop/ghub-20200425.2233/gsexp.el
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
;;; gsexp.el --- GraphQl as S-expressions -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2016-2020 Jonas Bernoulli
|
||||
|
||||
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||
;; Homepage: https://github.com/magit/ghub
|
||||
;; Keywords: tools
|
||||
|
||||
;; 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.
|
||||
|
||||
;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This library encodes S-expressions as GraphQl documents. Currently
|
||||
;; it is rather incomplete and only intended for use by `ghub-graphql'
|
||||
;; but I might fill the gaps and add documentation eventually. I am
|
||||
;; not in a hurry though.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
|
||||
(defun gsexp-encode (document)
|
||||
(gsexp--pp (gsexp--encode-field document)))
|
||||
|
||||
(defun gsexp--encode-field (field)
|
||||
(cond
|
||||
((stringp field)
|
||||
field)
|
||||
((symbolp field)
|
||||
(symbol-name field))
|
||||
((listp (car field))
|
||||
(concat (format "%s: " (caar field))
|
||||
(gsexp--encode-field (cons (cadar field)
|
||||
(cdr field)))))
|
||||
(t
|
||||
(concat (symbol-name (pop field))
|
||||
(and (vectorp (car field))
|
||||
(format " (\n%s)"
|
||||
(mapconcat #'gsexp--encode-argument
|
||||
(append (pop field) nil)
|
||||
",\n")))
|
||||
(and field
|
||||
(format " {\n%s\n}"
|
||||
(mapconcat #'gsexp--encode-field field "\n")))))))
|
||||
|
||||
(cl-defun gsexp--encode-argument ((argument value))
|
||||
(format "%s: %s" argument (gsexp--encode-value value)))
|
||||
|
||||
(defun gsexp--encode-value (value)
|
||||
(cond
|
||||
((numberp value)
|
||||
(number-to-string value))
|
||||
((symbolp value) ; including variables, enums, booleans and null
|
||||
(symbol-name value))
|
||||
((stringp value)
|
||||
(prin1-to-string value))
|
||||
((vectorp value)
|
||||
(format "(%s)" (mapconcat #'gsexp--encode-value value "")))
|
||||
((listp value)
|
||||
(format "{%s}" (mapconcat
|
||||
(pcase-lambda (`(,name ,value))
|
||||
(format "%s: %s" name (gsexp--encode-value value)))
|
||||
value ", ")))
|
||||
(t (error "Invalid field value: %S" value))))
|
||||
|
||||
(defun gsexp--pp (string)
|
||||
(with-temp-buffer
|
||||
(save-excursion
|
||||
(insert string))
|
||||
(while (< (point) (point-max))
|
||||
(unless (and (bolp) (eolp))
|
||||
(save-excursion
|
||||
(let ((level (car (syntax-ppss (point-at-bol)))))
|
||||
(when (looking-at "\\s-*\\s)")
|
||||
(cl-decf level))
|
||||
(indent-line-to (* 2 level)))))
|
||||
(forward-line 1))
|
||||
(buffer-string)))
|
||||
|
||||
;;; _
|
||||
(provide 'gsexp)
|
||||
;;; gsexp.el ends here
|
||||
BIN
26.3/develop/ghub-20200425.2233/gsexp.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/gsexp.elc
Normal file
Binary file not shown.
140
26.3/develop/ghub-20200425.2233/gtea.el
Normal file
140
26.3/develop/ghub-20200425.2233/gtea.el
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
;;; gtea.el --- minuscule client library for the Gitea API -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2016-2020 Jonas Bernoulli
|
||||
|
||||
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
||||
;; Homepage: https://github.com/magit/ghub
|
||||
;; Keywords: tools
|
||||
|
||||
;; 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.
|
||||
|
||||
;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Gtea is a library that provides basic support for using the Gitea API
|
||||
;; from Emacs packages. It abstracts access to API resources using only
|
||||
;; a handful of functions that are not resource-specific.
|
||||
|
||||
;; This library is implemented on top of Ghub. Unlike Ghub, Gtea does
|
||||
;; not support the guided creation of tokens because Gitea lacks the
|
||||
;; features that would be necessary to implement that. Users have to
|
||||
;; create tokens through the web interface.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ghub)
|
||||
|
||||
(defconst gtea-default-host "localhost:3000/api/v1"
|
||||
"The default Gitea host.")
|
||||
|
||||
;; HEAD does not appear to be supported.
|
||||
|
||||
(cl-defun gtea-get (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `GET' request for RESOURCE, with optional query PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"GET\" as METHOD
|
||||
and `gitea' as FORGE."
|
||||
(ghub-request "GET" resource params :forge 'gitea
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gtea-put (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PUT' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PUT\" as METHOD
|
||||
and `gitea' as FORGE."
|
||||
(ghub-request "PUT" resource params :forge 'gitea
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gtea-post (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `POST' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"POST\" as METHOD
|
||||
and `gitea' as FORGE."
|
||||
(ghub-request "POST" resource params :forge 'gitea
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gtea-patch (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `PATCH' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"PATCH\" as METHOD
|
||||
and `gitea' as FORGE."
|
||||
(ghub-request "PATCH" resource params :forge 'gitea
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gtea-delete (resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a `DELETE' request for RESOURCE, with optional payload PARAMS.
|
||||
Like calling `ghub-request' (which see) with \"DELETE\" as METHOD
|
||||
and `gitea' as FORGE."
|
||||
(ghub-request "DELETE" resource params :forge 'gitea
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gtea-request (method resource &optional params
|
||||
&key query payload headers
|
||||
silent unpaginate noerror reader
|
||||
username auth host
|
||||
callback errorback extra)
|
||||
"Make a request for RESOURCE and return the response body.
|
||||
Like calling `ghub-request' (which see) with `gitea' as FORGE."
|
||||
(ghub-request method resource params :forge 'gitea
|
||||
:query query :payload payload :headers headers
|
||||
:silent silent :unpaginate unpaginate
|
||||
:noerror noerror :reader reader
|
||||
:username username :auth auth :host host
|
||||
:callback callback :errorback errorback :extra extra))
|
||||
|
||||
(cl-defun gtea-repository-id (owner name &key username auth host)
|
||||
"Return the id of the repository specified by OWNER, NAME and HOST."
|
||||
(number-to-string
|
||||
(cdr (assq 'id (gtea-get (format "/repos/%s/%s" owner name)
|
||||
nil :username username :auth auth :host host)))))
|
||||
|
||||
;;; _
|
||||
(provide 'gtea)
|
||||
;;; gtea.el ends here
|
||||
BIN
26.3/develop/ghub-20200425.2233/gtea.elc
Normal file
BIN
26.3/develop/ghub-20200425.2233/gtea.elc
Normal file
Binary file not shown.
|
|
@ -95,6 +95,10 @@ Fork a gist.
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gist" '("dired-do-gist" "gist-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("gist-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -59,6 +59,10 @@ the current directory in eshell (`default-directory').
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "github-clone" '("github-clone-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("github-clone-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -36,6 +36,10 @@ Comment on a PR (to be run from a buffer corresponding to a review).
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "github-review" '("github-review-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("github-review-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -21,6 +21,10 @@ Query github using SEARCH-STRING and clone the selected repository.
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "github-search" '("github-search-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("github-search-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "logito" '("logito-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("logito-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -28,6 +28,10 @@
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "marshal" '("unmarshal-" "marshal-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("marshal-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@
|
|||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcache" '("pcache-" "constructor" "*pcache-repositor")))
|
||||
|
||||
;;;***
|
||||
|
||||
;;;### (autoloads nil nil ("pcache-pkg.el") (0 0 0 0))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
|
|
|
|||
22
26.3/develop/treepy-20191108.2217/treepy-autoloads.el
Normal file
22
26.3/develop/treepy-20191108.2217/treepy-autoloads.el
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
;;; treepy-autoloads.el --- automatically extracted autoloads
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(add-to-list 'load-path (directory-file-name
|
||||
(or (file-name-directory #$) (car load-path))))
|
||||
|
||||
|
||||
;;;### (autoloads nil "treepy" "treepy.el" (0 0 0 0))
|
||||
;;; Generated autoloads from treepy.el
|
||||
|
||||
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "treepy" '("treepy-")))
|
||||
|
||||
;;;***
|
||||
|
||||
;; Local Variables:
|
||||
;; version-control: never
|
||||
;; no-byte-compile: t
|
||||
;; no-update-autoloads: t
|
||||
;; coding: utf-8
|
||||
;; End:
|
||||
;;; treepy-autoloads.el ends here
|
||||
2
26.3/develop/treepy-20191108.2217/treepy-pkg.el
Normal file
2
26.3/develop/treepy-20191108.2217/treepy-pkg.el
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
;;; -*- no-byte-compile: t -*-
|
||||
(define-package "treepy" "20191108.2217" "Generic tree traversal tools" '((emacs "25.1")) :commit "306f7031d26e4ebfc9ff36614acdc6993f3e23c3" :keywords '("lisp" "maint" "tools") :authors '(("Daniel Barreto" . "daniel.barreto.n@gmail.com")) :maintainer '("Daniel Barreto" . "daniel.barreto.n@gmail.com") :url "https://github.com/volrath/treepy.el")
|
||||
485
26.3/develop/treepy-20191108.2217/treepy.el
Normal file
485
26.3/develop/treepy-20191108.2217/treepy.el
Normal file
|
|
@ -0,0 +1,485 @@
|
|||
;;; treepy.el --- Generic tree traversal tools -*- lexical-binding: t -*-
|
||||
;;
|
||||
;; Filename: treepy.el
|
||||
;;
|
||||
;; Copyright (C) 2017 Daniel Barreto
|
||||
;;
|
||||
;; Description: Generic Tree Traversing Tools
|
||||
;; Author: Daniel Barreto <daniel.barreto.n@gmail.com>
|
||||
;; Keywords: lisp, maint, tools
|
||||
;; Package-Version: 20191108.2217
|
||||
;; Created: Mon Jul 10 15:17:36 2017 (+0200)
|
||||
;; Version: 0.1.1
|
||||
;; Package-Requires: ((emacs "25.1"))
|
||||
;; URL: https://github.com/volrath/treepy.el
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Generic tools for recursive and iterative tree traversal based on
|
||||
;; clojure.walk and clojure.zip respectively. Depends on `map', a map
|
||||
;; manipulation library built in Emacs 25.1. All functions are prefixed
|
||||
;; with "treepy-"
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; 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 'map)
|
||||
(require 'cl-lib)
|
||||
|
||||
;;; Walk (recursive tree traversal)
|
||||
|
||||
(defun treepy-walk (inner outer form)
|
||||
"Using INNER and OUTER, traverse FORM, an arbitrary data structure.
|
||||
INNER and OUTER are functions. Apply INNER to each element of
|
||||
FORM, building up a data structure of the same type, then apply
|
||||
OUTER to the result. Recognize cons, lists, alists, vectors and
|
||||
hash tables."
|
||||
(cond
|
||||
((and (listp form) (cdr form) (atom (cdr form))) (funcall outer (cons (funcall inner (car form))
|
||||
(funcall inner (cdr form)))))
|
||||
((listp form) (funcall outer (mapcar inner form)))
|
||||
((vectorp form) (funcall outer (apply #'vector (mapcar inner form))))
|
||||
((hash-table-p form) (funcall outer (map-apply (lambda (k v) (funcall inner (cons k v))) form)))
|
||||
(t (funcall outer form))))
|
||||
|
||||
(defun treepy-postwalk (f form)
|
||||
"Perform a depth-first, post-order traversal of F applied to FORM.
|
||||
Call F on each sub-form, use F's return value in place of the
|
||||
original. Recognize cons, lists, alists, vectors and
|
||||
hash tables."
|
||||
(treepy-walk (apply-partially #'treepy-postwalk f) f form))
|
||||
|
||||
(defun treepy-prewalk (f form)
|
||||
"Perform a depth-first, pre-order traversal of F applied to FORM.
|
||||
Like `treepy-postwalk'."
|
||||
(treepy-walk (apply-partially #'treepy-prewalk f) #'identity (funcall f form)))
|
||||
|
||||
(defun treepy-postwalk-demo (form)
|
||||
"Demonstrate the behavior of `treepy-postwalk' for FORM.
|
||||
Return a list of each form as it is walked."
|
||||
(let ((walk nil))
|
||||
(treepy-postwalk (lambda (x) (push x walk) x)
|
||||
form)
|
||||
(reverse walk)))
|
||||
|
||||
(defun treepy-prewalk-demo (form)
|
||||
"Demonstrate the behavior of `treepy-prewalk' for FORM.
|
||||
Return a list of each form as it is walked."
|
||||
(let ((walk nil))
|
||||
(treepy-prewalk (lambda (x) (push x walk) x)
|
||||
form)
|
||||
(reverse walk)))
|
||||
|
||||
(defun treepy-postwalk-replace (smap form &optional testfn)
|
||||
"Use SMAP to transform FORM by doing replacing operations.
|
||||
Recursively replace in FORM keys in SMAP with their values. Does
|
||||
replacement at the leaves of the tree first. The optional TESTFN
|
||||
parameter is the function to be used by `map-contains-key'."
|
||||
(treepy-postwalk (lambda (x) (if (map-contains-key smap x testfn) (map-elt smap x) x))
|
||||
form))
|
||||
|
||||
(defun treepy-prewalk-replace (smap form &optional testfn)
|
||||
"Use SMAP to transform FORM by doing replacing operations.
|
||||
Recursively replace in FORM keys in SMAP with their values. Does
|
||||
replacement at the root of the tree first. The optional TESTFN
|
||||
parameter is the function to be used by `map-contains-key'."
|
||||
(treepy-prewalk (lambda (x) (if (map-contains-key smap x testfn) (map-elt smap x) x))
|
||||
form))
|
||||
|
||||
|
||||
;;; Zipper (iterative tree traversal)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun treepy--context (loc &optional key)
|
||||
"Return context for this LOC.
|
||||
If KEY is given, only return this key's value in context."
|
||||
(let ((context (cdr (car loc))))
|
||||
(if (and context key)
|
||||
(map-elt context key)
|
||||
context)))
|
||||
|
||||
(defun treepy--context-assoc-1 (context k v)
|
||||
"Assoc in CONTEXT a key K with a value V."
|
||||
(if (map-contains-key context k)
|
||||
(mapcar (lambda (entry)
|
||||
(if (equal (car entry) k)
|
||||
(cons k v)
|
||||
entry))
|
||||
context)
|
||||
(cons (cons k v) context)))
|
||||
|
||||
(defun treepy--context-assoc (context &rest kvs)
|
||||
"Immutable map association in CONTEXT using KVS."
|
||||
(seq-reduce (lambda (context kv)
|
||||
(seq-let [k v] kv
|
||||
(treepy--context-assoc-1 context k v)))
|
||||
(seq-partition kvs 2) context))
|
||||
|
||||
(defun treepy--meta (loc &optional key)
|
||||
"Return meta information for this LOC.
|
||||
If KEY is given, only return this key's value in meta
|
||||
information."
|
||||
(let ((meta (cdr loc)))
|
||||
(if key
|
||||
(map-elt meta key)
|
||||
meta)))
|
||||
|
||||
(defun treepy--with-meta (obj meta)
|
||||
"Bind OBJ with some META information."
|
||||
(cons obj meta))
|
||||
|
||||
(defun treepy--join-children (left-children right-children)
|
||||
"Return a joining of LEFT-CHILDREN and RIGHT-CHILDREN.
|
||||
Reverses LEFT-CHILDREN so that they are correctly ordered as in
|
||||
the tree."
|
||||
(append (reverse left-children) right-children))
|
||||
|
||||
(defmacro treepy--with-loc (loc vars &rest body)
|
||||
"Create a lexical context using LOC VARS.
|
||||
Execute BODY in this context."
|
||||
(declare (indent defun))
|
||||
(let ((lex-ctx (mapcar (lambda (v)
|
||||
(cl-case v
|
||||
('node `(node (treepy-node ,loc)))
|
||||
('context `(context (treepy--context ,loc)))
|
||||
(t `(,v (treepy--context ,loc (quote ,(intern (concat ":" (symbol-name v)))))))))
|
||||
vars)))
|
||||
`(let* (,@lex-ctx) ,@body)))
|
||||
|
||||
;;;; Construction
|
||||
|
||||
(defun treepy-zipper (branchp children make-node root)
|
||||
"Create a new zipper structure.
|
||||
|
||||
BRANCHP is a function that, given a node, returns t if it can
|
||||
have children, even if it currently doesn't.
|
||||
|
||||
CHILDREN is a function that, given a branch node, returns a seq
|
||||
of its children.
|
||||
|
||||
MAKE-NODE is a function that, given an existing node and a seq of
|
||||
children, returns a new branch node with the supplied children.
|
||||
|
||||
ROOT is the root node."
|
||||
(treepy--with-meta
|
||||
(cons root nil)
|
||||
`((:branchp . ,branchp) (:children . ,children) (:make-node . ,make-node))))
|
||||
|
||||
(defun treepy-list-zip (root)
|
||||
"Return a zipper for nested lists, given a ROOT list."
|
||||
(let ((make-node (lambda (_ children) children)))
|
||||
(treepy-zipper #'listp #'identity make-node root)))
|
||||
|
||||
(defun treepy-vector-zip (root)
|
||||
"Return a zipper for nested vectors, given a ROOT vector."
|
||||
(let ((make-node (lambda (_ children) (apply #'vector children)))
|
||||
(children (lambda (cs) (seq-into cs 'list))))
|
||||
(treepy-zipper #'vectorp children make-node root)))
|
||||
|
||||
;;;; Context
|
||||
|
||||
(defun treepy-node (loc)
|
||||
"Return the node at LOC."
|
||||
(caar loc))
|
||||
|
||||
(defun treepy-branch-p (loc)
|
||||
"Return t if the node at LOC is a branch."
|
||||
(funcall (treepy--meta loc ':branchp) (treepy-node loc)))
|
||||
|
||||
(defun treepy-children (loc)
|
||||
"Return a children list of the node at LOC, which must be a branch."
|
||||
(if (treepy-branch-p loc)
|
||||
(funcall (treepy--meta loc ':children) (treepy-node loc))
|
||||
(error "Called children on a leaf node")))
|
||||
|
||||
(defun treepy-make-node (loc node children)
|
||||
"Return a new branch node.
|
||||
Given an existing LOC, NODE and new CHILDREN, creates a new LOC
|
||||
with them. The LOC is only used to supply the constructor."
|
||||
(funcall (treepy--meta loc ':make-node) node children))
|
||||
|
||||
(defun treepy-path (loc)
|
||||
"Return a list of nodes leading to the given LOC."
|
||||
(reverse (treepy--context loc ':pnodes)))
|
||||
|
||||
(defun treepy-lefts (loc)
|
||||
"Return a list of the left siblings of this LOC."
|
||||
(reverse (treepy--context loc ':l)))
|
||||
|
||||
(defun treepy-rights (loc)
|
||||
"Return a list of the right siblings of this LOC."
|
||||
(treepy--context loc ':r))
|
||||
|
||||
;;;; Navigation
|
||||
|
||||
(defun treepy-down (loc)
|
||||
"Return the loc of the leftmost child of the node at this LOC.
|
||||
nil if no children."
|
||||
(when (treepy-branch-p loc)
|
||||
(let ((children (treepy-children loc)))
|
||||
(treepy--with-loc loc (node context pnodes)
|
||||
(seq-let [c &rest cs] children
|
||||
(when children
|
||||
(treepy--with-meta
|
||||
`(,c . ((:l . ,nil)
|
||||
(:pnodes . ,(if context (cons node pnodes) (list node)))
|
||||
(:ppath . ,context)
|
||||
(:r . ,cs)))
|
||||
(treepy--meta loc))))))))
|
||||
|
||||
(defun treepy-up (loc)
|
||||
"Return the loc of the parent of the node at this LOC.
|
||||
nil if at the top."
|
||||
(treepy--with-loc loc (node pnodes ppath changed? l r)
|
||||
(when pnodes
|
||||
(let ((pnode (car pnodes)))
|
||||
(treepy--with-meta
|
||||
(if changed?
|
||||
(cons (treepy-make-node loc pnode (treepy--join-children l (cons node r)))
|
||||
(and ppath (treepy--context-assoc ppath ':changed? t)))
|
||||
(cons pnode ppath))
|
||||
(treepy--meta loc))))))
|
||||
|
||||
(defun treepy-root (loc)
|
||||
"Zip from LOC all the way up and return the root node.
|
||||
Reflect any alterations to the tree."
|
||||
(if (equal :end (treepy--context loc))
|
||||
(treepy-node loc)
|
||||
(let ((p loc))
|
||||
(while (setq p (treepy-up p))
|
||||
(setq loc p))
|
||||
(treepy-node loc))))
|
||||
|
||||
(defun treepy-right (loc)
|
||||
"Return the loc of the right sibling of the node at this LOC.
|
||||
nil if there's no more right sibilings."
|
||||
(treepy--with-loc loc (node context l r)
|
||||
(let ((r (if (listp r)
|
||||
r
|
||||
;; If `r' is not a list (or nil), then we're dealing with a non
|
||||
;; nil cdr ending list.
|
||||
(cons r nil))))
|
||||
(seq-let [cr &rest rnext] r
|
||||
(when (and context r)
|
||||
(treepy--with-meta
|
||||
(cons cr
|
||||
(treepy--context-assoc context
|
||||
':l (cons node l)
|
||||
':r rnext))
|
||||
(treepy--meta loc)))))))
|
||||
|
||||
|
||||
(defun treepy-rightmost (loc)
|
||||
"Return the loc of the rightmost sibling of the node at this LOC.
|
||||
If LOC is already the rightmost sibling, return self."
|
||||
(treepy--with-loc loc (node context l r)
|
||||
(if (and context r)
|
||||
(treepy--with-meta
|
||||
(cons (car (last r))
|
||||
(treepy--context-assoc context
|
||||
':l (treepy--join-children l (cons node (butlast r)))
|
||||
':r nil))
|
||||
(treepy--meta loc))
|
||||
loc)))
|
||||
|
||||
(defun treepy-left (loc)
|
||||
"Return the loc of the left sibling of the node at this LOC.
|
||||
nil if no more left sibilings."
|
||||
(treepy--with-loc loc (node context l r)
|
||||
(when (and context l)
|
||||
(seq-let [cl &rest lnext] l
|
||||
(treepy--with-meta
|
||||
(cons cl
|
||||
(treepy--context-assoc context
|
||||
':l lnext
|
||||
':r (cons node r)))
|
||||
(treepy--meta loc))))))
|
||||
|
||||
(defun treepy-leftmost (loc)
|
||||
"Return the loc of the leftmost sibling of the node at this LOC.
|
||||
If LOC is already the leftmost sibling, return self."
|
||||
(treepy--with-loc loc (node context l r)
|
||||
(if (and context l)
|
||||
(treepy--with-meta
|
||||
(cons (car (last l))
|
||||
(treepy--context-assoc context
|
||||
':l []
|
||||
':r (treepy--join-children (butlast l) (cons node r))))
|
||||
(treepy--meta loc))
|
||||
loc)))
|
||||
|
||||
(defun treepy-leftmost-descendant (loc)
|
||||
"Return the leftmost descendant of the given LOC.
|
||||
\(ie, down repeatedly)."
|
||||
(while (treepy-branch-p loc)
|
||||
(setq loc (treepy-down loc)))
|
||||
loc)
|
||||
|
||||
;;;; Modification
|
||||
|
||||
(defun treepy-insert-left (loc item)
|
||||
"Insert as the left sibling of this LOC'S node the ITEM.
|
||||
Return same loc with sibilings updated."
|
||||
(treepy--with-loc loc (node context l)
|
||||
(if (not context)
|
||||
(error "Insert at top")
|
||||
(treepy--with-meta
|
||||
(cons node
|
||||
(treepy--context-assoc context
|
||||
':l (cons item l)
|
||||
':changed? t))
|
||||
(treepy--meta loc)))))
|
||||
|
||||
(defun treepy-insert-right (loc item)
|
||||
"Insert as the right sibling of this LOC's node the ITEM.
|
||||
Return same loc with sibilings updated."
|
||||
(treepy--with-loc loc (node context r)
|
||||
(if (not context)
|
||||
(error "Insert at top")
|
||||
(treepy--with-meta
|
||||
(cons node
|
||||
(treepy--context-assoc context
|
||||
':r (cons item r)
|
||||
':changed? t))
|
||||
(treepy--meta loc)))))
|
||||
|
||||
(defun treepy-replace (loc node)
|
||||
"Replace the node in this LOC with the given NODE, without moving."
|
||||
(let ((context (treepy--context loc)))
|
||||
(treepy--with-meta
|
||||
(cons node
|
||||
(treepy--context-assoc context
|
||||
':changed? t))
|
||||
(treepy--meta loc))))
|
||||
|
||||
(defun treepy-edit (loc f &rest args)
|
||||
"Replace the node at this LOC with the value of (F node ARGS)."
|
||||
(treepy-replace loc (apply f (treepy-node loc) args)))
|
||||
|
||||
(defun treepy-insert-child (loc item)
|
||||
"Insert as the leftmost child of this LOC's node the ITEM.
|
||||
Return same loc with children updated."
|
||||
(treepy-replace loc (treepy-make-node loc (treepy-node loc) (cons item (treepy-children loc)))))
|
||||
|
||||
(defun treepy-append-child (loc item)
|
||||
"Insert as the rightmost child of this LOC'S node the ITEM.
|
||||
Return same loc with children updated."
|
||||
(treepy-replace loc (treepy-make-node loc (treepy-node loc) (append (treepy-children loc) `(,item))))) ;; TODO: check performance
|
||||
|
||||
(defun treepy-remove (loc)
|
||||
"Remove the node at LOC.
|
||||
Return the loc that would have preceded it in a depth-first
|
||||
walk."
|
||||
(treepy--with-loc loc (context pnodes ppath l r)
|
||||
(if (not context)
|
||||
(error "Remove at top")
|
||||
(if (> (length l) 0)
|
||||
(let ((nloc (treepy--with-meta (cons (car l)
|
||||
(treepy--context-assoc context
|
||||
':l (cdr l)
|
||||
':changed? t))
|
||||
(treepy--meta loc)))
|
||||
(child nil))
|
||||
(while (setq child (and (treepy-branch-p nloc) (treepy-children nloc)))
|
||||
(setq nloc (treepy-rightmost child)))
|
||||
nloc)
|
||||
(treepy--with-meta
|
||||
(cons (treepy-make-node loc (car pnodes) r)
|
||||
(and ppath (treepy--context-assoc context ':changed? t)))
|
||||
(treepy--meta loc))))))
|
||||
|
||||
;;;; Enumeration
|
||||
|
||||
(defun treepy--preorder-next (loc)
|
||||
"Move to the next LOC in the hierarchy, depth-first in preorder.
|
||||
When reaching the end, returns a distinguished loc detectable via
|
||||
`treepy-end-p'. If already at the end, stays there."
|
||||
(if (equal :end (treepy--context loc))
|
||||
loc
|
||||
(let ((cloc loc))
|
||||
(or
|
||||
(and (treepy-branch-p cloc) (treepy-down cloc))
|
||||
(treepy-right cloc)
|
||||
(let ((p cloc)
|
||||
(pr nil))
|
||||
(while (and (treepy-up p) (not (setq pr (treepy-right (treepy-up p)))))
|
||||
(setq p (treepy-up p)))
|
||||
(or pr (cons (cons (treepy-node p) :end) nil)))))))
|
||||
|
||||
(defun treepy--postorder-next (loc)
|
||||
"Move to the next LOC in the hierarchy, depth-first in postorder.
|
||||
When reaching the end, returns a distinguished loc detectable via
|
||||
`treepy-end-p'. If already at the end, stays there."
|
||||
(if (equal :end (treepy--context loc))
|
||||
loc
|
||||
(if (null (treepy-up loc))
|
||||
(cons (cons (treepy-node loc) :end) nil)
|
||||
(or (let ((rloc (treepy-right loc)))
|
||||
(and rloc (treepy-leftmost-descendant rloc)))
|
||||
(treepy-up loc)))))
|
||||
|
||||
(defun treepy-next (loc &optional order)
|
||||
"Move to the next LOC in the hierarchy, depth-first.
|
||||
Use ORDER if given. Possible values for ORDER are `:preorder' and
|
||||
`:postorder', defaults to the former."
|
||||
(cl-case (or order ':preorder)
|
||||
(':preorder (treepy--preorder-next loc))
|
||||
(':postorder (treepy--postorder-next loc))
|
||||
(t (error "Unrecognized order"))))
|
||||
|
||||
(defun treepy--preorder-prev (loc)
|
||||
"Move to the previous LOC in the hierarchy, depth-first preorder.
|
||||
If already at the root, returns nil."
|
||||
(let ((lloc (treepy-left loc))
|
||||
(child nil))
|
||||
(if lloc
|
||||
(progn
|
||||
(while (setq child (and (treepy-branch-p lloc) (treepy-children lloc)))
|
||||
(setq lloc (treepy-rightmost child)))
|
||||
lloc)
|
||||
(treepy-up loc))))
|
||||
|
||||
(defun treepy--postorder-prev (loc)
|
||||
"Move to the previous LOC in the hierarchy, depth-first postorder.
|
||||
If already at the root, returns nil."
|
||||
(if (treepy-branch-p loc)
|
||||
(treepy-rightmost (treepy-down loc))
|
||||
(progn
|
||||
(while (not (treepy-left loc))
|
||||
(setq loc (treepy-up loc)))
|
||||
(treepy-left loc))))
|
||||
|
||||
(defun treepy-prev (loc &optional order)
|
||||
"Move to the previous LOC in the hierarchy, depth-first.
|
||||
Use ORDER if given. Possible values for ORDER are `:preorder' and `:postorder',
|
||||
defaults to the former."
|
||||
(cl-case (or order ':preorder)
|
||||
(':preorder (treepy--preorder-prev loc))
|
||||
(':postorder (treepy--postorder-prev loc))
|
||||
(t (error "Unrecognized order"))))
|
||||
|
||||
(defun treepy-end-p (loc)
|
||||
"Return t if LOC represents the end of a depth-first walk."
|
||||
(equal :end (treepy--context loc)))
|
||||
|
||||
(provide 'treepy)
|
||||
|
||||
;;; treepy.el ends here
|
||||
BIN
26.3/develop/treepy-20191108.2217/treepy.elc
Normal file
BIN
26.3/develop/treepy-20191108.2217/treepy.elc
Normal file
Binary file not shown.
BIN
gnupg/pubring.kbx
Normal file
BIN
gnupg/pubring.kbx
Normal file
Binary file not shown.
BIN
gnupg/pubring.kbx~
Normal file
BIN
gnupg/pubring.kbx~
Normal file
Binary file not shown.
BIN
gnupg/trustdb.gpg
Normal file
BIN
gnupg/trustdb.gpg
Normal file
Binary file not shown.
Loading…
Reference in a new issue