506 lines
18 KiB
EmacsLisp
506 lines
18 KiB
EmacsLisp
;;; sx.el --- StackExchange client. Ask and answer questions on Stack Overflow, Super User, and the likes -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2014 Sean Allred
|
||
|
||
;; Author: Sean Allred <code@seanallred.com>
|
||
;; URL: https://github.com/vermiculus/sx.el/
|
||
;; Version: 0.3
|
||
;; Keywords: help, hypermedia, tools
|
||
;; Package-Requires: ((emacs "24.1") (cl-lib "0.5") (json "1.3") (markdown-mode "2.0") (let-alist "1.0.3"))
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; This file defines basic commands used by all other parts of SX.
|
||
|
||
;;; Code:
|
||
(require 'tabulated-list)
|
||
|
||
(defconst sx-version "0.3" "Version of the `sx' package.")
|
||
|
||
(defgroup sx nil
|
||
"Customization group for the `sx' package."
|
||
:prefix "sx-"
|
||
:tag "SX"
|
||
:group 'applications)
|
||
|
||
|
||
;;; User commands
|
||
(defun sx-version ()
|
||
"Print and return the version of the `sx' package."
|
||
(interactive)
|
||
(message "%s: %s" 'sx-version sx-version)
|
||
sx-version)
|
||
|
||
;;;###autoload
|
||
(defun sx-bug-report ()
|
||
"File a bug report about the `sx' package."
|
||
(interactive)
|
||
(browse-url "https://github.com/vermiculus/sx.el/issues/new"))
|
||
|
||
|
||
;;; Site
|
||
(defun sx--site (data)
|
||
"Get the site in which DATA belongs.
|
||
DATA can be a question, answer, comment, or user (or any object
|
||
with a `link' property).
|
||
DATA can also be the link itself."
|
||
(let ((link (if (stringp data) data
|
||
(cdr (assoc 'link data)))))
|
||
(when (stringp link)
|
||
(replace-regexp-in-string
|
||
(rx string-start
|
||
"http" (optional "s") "://"
|
||
(or
|
||
(sequence
|
||
(group-n 1 (+ (not (any "/"))))
|
||
".stackexchange")
|
||
(group-n 2 (+ (not (any "/")))))
|
||
"." (+ (not (any ".")))
|
||
"/" (* any)
|
||
string-end)
|
||
"\\1\\2" link))))
|
||
|
||
(defun sx--ensure-site (data)
|
||
"Add a `site' property to DATA if it doesn't have one. Return DATA.
|
||
DATA can be a question, answer, comment, or user (or any object
|
||
with a `link' property)."
|
||
(when data
|
||
(let-alist data
|
||
(unless .site_par
|
||
;; @TODO: Change this to .site.api_site_parameter sometime
|
||
;; after February.
|
||
(setcdr data (cons (cons 'site_par
|
||
(or (cdr (assq 'api_site_parameter .site))
|
||
(sx--site data)))
|
||
(cdr data)))))
|
||
data))
|
||
|
||
(defun sx--link-to-data (link)
|
||
"Convert string LINK into data that can be displayed."
|
||
(let ((result (list (cons 'site_par (sx--site link)))))
|
||
;; Try to strip a question or answer ID
|
||
(when (cond ;; Comment
|
||
((or ;; If there's a #commentNUMBER_NUMBER at the end, we
|
||
;; know it's a comment with that ID.
|
||
(string-match (rx "#comment" (group-n 1 (+ digit))
|
||
"_" (+ digit) string-end)
|
||
link)
|
||
;; From inbox items
|
||
(string-match (rx "/posts/comments/"
|
||
;; Comment ID
|
||
(group-n 1 (+ digit))
|
||
;; Optional stuff at the end
|
||
(or (and (any "?#") (* any)) "")
|
||
string-end)
|
||
link))
|
||
(push '(type . comment) result))
|
||
;; Answer
|
||
((or ;; If there's a #NUMBER at the end, we know it's an
|
||
;; answer with that ID.
|
||
(string-match (rx "#" (group-n 1 (+ digit)) string-end) link)
|
||
;; From 'Share' button
|
||
(string-match (rx "/a/"
|
||
;; Answer ID
|
||
(group-n 1 (+ digit)) "/"
|
||
;; User ID
|
||
(+ digit)
|
||
;; Garbage at the end
|
||
(optional (and (any "?#") (* any)))
|
||
string-end)
|
||
link)
|
||
;; From URL
|
||
(string-match (rx "/questions/" (+ digit) "/"
|
||
;; Question title
|
||
(+ (not (any "/"))) "/"
|
||
;; Answer ID. If this is absent, we match on
|
||
;; Question clause below.
|
||
(group-n 1 (+ digit))
|
||
(opt "/")
|
||
;; Garbage at the end
|
||
(optional (and (any "?#") (* any)))
|
||
string-end)
|
||
link))
|
||
(push '(type . answer) result))
|
||
;; Question
|
||
((or ;; From 'Share' button
|
||
(string-match (rx "/q/"
|
||
;; Question ID
|
||
(group-n 1 (+ digit))
|
||
;; User ID
|
||
(optional "/" (+ digit))
|
||
;; Garbage at the end
|
||
(optional (and (any "?#") (* any)))
|
||
string-end)
|
||
link)
|
||
;; From URL
|
||
(string-match (rx "/questions/"
|
||
;; Question ID
|
||
(group-n 1 (+ digit)) "/")
|
||
link))
|
||
(push '(type . question) result)))
|
||
(push (cons 'id (string-to-number (match-string-no-properties 1 link)))
|
||
result))
|
||
result))
|
||
|
||
(defun sx--tree-paths (tree)
|
||
"Return a list of all paths in TREE.
|
||
Adapted from http://stackoverflow.com/q/3019250."
|
||
(if (atom tree)
|
||
(list (list tree))
|
||
(apply #'append
|
||
(mapcar (lambda (node)
|
||
(mapcar (lambda (path)
|
||
(cons (car tree) path))
|
||
(sx--tree-paths node)))
|
||
(cdr tree)))))
|
||
|
||
(defun sx--tree-expand (path-func tree)
|
||
"Apply PATH-FUNC to every path in TREE.
|
||
Return the result. See `sx--tree-paths'."
|
||
(mapcar path-func
|
||
(apply #'append
|
||
(mapcar #'sx--tree-paths
|
||
tree))))
|
||
|
||
(defmacro sx-assoc-let (alist &rest body)
|
||
"Use ALIST with `let-alist' to execute BODY.
|
||
`.site_par' has a special meaning, thanks to `sx--ensure-site'.
|
||
If ALIST doesn't have a `site' property, one is created using the
|
||
`link' property."
|
||
(declare (indent 1) (debug t))
|
||
(require 'let-alist)
|
||
`(progn
|
||
(sx--ensure-site ,alist)
|
||
,(macroexpand
|
||
`(let-alist ,alist ,@body))))
|
||
|
||
(defun sx--pretty-site-parameter (site)
|
||
"Returned a pretty and capitalized version of string SITE."
|
||
(mapconcat #'capitalize
|
||
(split-string site "\\.")
|
||
" "))
|
||
|
||
|
||
;;; Utility Functions
|
||
(defun sx--split-string (string &optional separators)
|
||
"Split STRING into substrings bounded by matches for SEPARATORS."
|
||
(mapcar (lambda (s) (replace-regexp-in-string "\\` +\\| +\\'" "" s))
|
||
(split-string string separators 'omit-nulls)))
|
||
|
||
(defun sx-completing-read (&rest args)
|
||
"Like `completing-read', but possibly use ido.
|
||
All ARGS are passed to `completing-read' or `ido-completing-read'."
|
||
(apply (if ido-mode #'ido-completing-read #'completing-read)
|
||
args))
|
||
|
||
(defun sx-user-error (format-string &rest args)
|
||
"Like `user-error', but prepend FORMAT-STRING with \"[sx]\".
|
||
See `format'."
|
||
(signal 'user-error
|
||
(list (apply #'format (concat "[sx] " format-string) args))))
|
||
|
||
(defun sx-message (format-string &rest args)
|
||
"Display FORMAT-STRING as a message with ARGS.
|
||
See `format'."
|
||
(message "[sx] %s" (apply #'format format-string args)))
|
||
|
||
(defun sx-message-help-echo ()
|
||
"If there's a 'help-echo property under point, message it."
|
||
(let ((echo (get-text-property (point) 'help-echo)))
|
||
(when echo (message "%s" echo))))
|
||
|
||
(defun sx--thing-as-string (thing &optional sequence-sep url-hexify)
|
||
"Return a string representation of THING.
|
||
If THING is already a string, just return it.
|
||
|
||
Optional argument SEQUENCE-SEP is the separator applied between
|
||
elements of a sequence. If SEQUENCE-SEP is a list, use the first
|
||
element for the top level joining, the second for the next level,
|
||
etc. \";\" is used as a default.
|
||
|
||
If optional argument URL-HEXIFY is non-nil, this function behaves
|
||
as `url-hexify-string'; this option is only effective on strings
|
||
and sequences of strings."
|
||
(let ((process (if url-hexify #'url-hexify-string #'identity))
|
||
(first-f (if (listp sequence-sep) #'car #'identity))
|
||
(rest-f (if (listp sequence-sep) #'cdr #'identity)))
|
||
(cond
|
||
((stringp thing) (funcall process thing))
|
||
((symbolp thing) (funcall process (symbol-name thing)))
|
||
((numberp thing) (number-to-string thing))
|
||
((sequencep thing)
|
||
(mapconcat (lambda (thing)
|
||
(sx--thing-as-string
|
||
thing (funcall rest-f sequence-sep) url-hexify))
|
||
thing (if sequence-sep
|
||
(funcall first-f sequence-sep)
|
||
";"))))))
|
||
|
||
(defun sx--shorten-url (url)
|
||
"Shorten URL hiding anything other than the domain.
|
||
Paths after the domain are replaced with \"...\".
|
||
Anything before the (sub)domain is removed."
|
||
(replace-regexp-in-string
|
||
;; Remove anything after domain.
|
||
(rx (group-n 1 (and (1+ (any word ".")) "/"))
|
||
(1+ anything) string-end)
|
||
(eval-when-compile
|
||
(concat "\\1" (if (char-displayable-p ?…) "…" "...")))
|
||
;; Remove anything before subdomain.
|
||
(replace-regexp-in-string
|
||
(rx string-start (or (and (0+ word) (optional ":") "//")))
|
||
"" url)))
|
||
|
||
(defmacro sx--define-conditional-key (keymap key def &rest body)
|
||
"In KEYMAP, define key sequence KEY as DEF conditionally.
|
||
This is like `define-key', except the definition \"disappears\"
|
||
whenever BODY evaluates to nil."
|
||
(declare (indent 3)
|
||
(debug (form form form &rest sexp)))
|
||
`(define-key ,keymap ,key
|
||
'(menu-item
|
||
,(format "maybe-%s" (or (car (cdr-safe def)) def)) ignore
|
||
:filter (lambda (&optional _)
|
||
(when (progn ,@body) ,def)))))
|
||
|
||
(defun sx--goto-property-change (prop &optional direction)
|
||
"Move forward to the next change of text-property PROP.
|
||
Return the new value of PROP at point.
|
||
|
||
If DIRECTION is negative, move backwards instead."
|
||
(let ((func (if (and (numberp direction)
|
||
(< direction 0))
|
||
#'previous-single-property-change
|
||
#'next-single-property-change))
|
||
(limit (if (and (numberp direction)
|
||
(< direction 0))
|
||
(point-min) (point-max))))
|
||
(goto-char (funcall func (point) prop nil limit))
|
||
(get-text-property (point) prop)))
|
||
|
||
(defun sx--find-in-buffer (type id)
|
||
"Move point to an object of TYPE and ID.
|
||
That is, move forward from beginning of buffer until
|
||
`sx--data-here' is an object of type TYPE with the respective id
|
||
ID. If point is left at the of a line, move over the line break.
|
||
|
||
TYPE is either question, answer, or comment.
|
||
ID is an integer."
|
||
(let* ((id-symbol (cl-case type
|
||
(answer 'answer_id)
|
||
(comment 'comment_id)
|
||
(question 'question_id)))
|
||
(pos
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(while (not (or (eobp)
|
||
(let ((data (sx--data-here type t)))
|
||
(and data
|
||
(= id (or (cdr (assq id-symbol data))))))))
|
||
(forward-char 1))
|
||
(point))))
|
||
(if (equal pos (point-max))
|
||
(sx-message "Can't find the specified %s" type)
|
||
(goto-char pos)
|
||
(when (looking-at-p "$")
|
||
(forward-char 1)))))
|
||
|
||
(defmacro sx--create-comparator (name doc compare-func get-func)
|
||
"Define a new comparator called NAME with documentation DOC.
|
||
COMPARE-FUNC is a function that takes the return value of
|
||
GET-FUNC and performs the actual comparison."
|
||
(declare (indent 1) (doc-string 2))
|
||
`(defun ,name (a b)
|
||
,doc
|
||
(funcall ,compare-func
|
||
(funcall ,get-func a)
|
||
(funcall ,get-func b))))
|
||
|
||
(defun sx--squash-whitespace (string)
|
||
"Return STRING with consecutive whitespace squashed together."
|
||
(replace-regexp-in-string "[ \r\n]+" " " string))
|
||
|
||
(defun sx--deleted-p (data)
|
||
"Return non-nil if DATA represents a deleted object."
|
||
(eq (car data) 'deleted))
|
||
|
||
(defun sx--invert-predicate (predicate)
|
||
"Return PREDICATE function with arguments inverted.
|
||
For instance (sx--invert-predicate #'<) is the same as #'>.
|
||
Note this is not the same as negating PREDICATE."
|
||
(lambda (&rest args) (apply predicate (reverse args))))
|
||
|
||
|
||
;;; Printing request data
|
||
(defvar sx--overlays nil
|
||
"Overlays created by sx on this buffer.")
|
||
(make-variable-buffer-local 'sx--overlays)
|
||
|
||
(defvar sx--overlay-printing-depth 0
|
||
"Track how many overlays we're printing on top of each other.
|
||
Used for assigning higher priority to inner overlays.")
|
||
(make-variable-buffer-local 'sx--overlay-printing-depth)
|
||
|
||
(defmacro sx--wrap-in-overlay (properties &rest body)
|
||
"Start a scope with overlay PROPERTIES and execute BODY.
|
||
Overlay is pushed on the buffer-local variable `sx--overlays' and
|
||
given PROPERTIES.
|
||
|
||
Return the result of BODY."
|
||
(declare (indent 1)
|
||
(debug t))
|
||
`(let ((p (point-marker))
|
||
(result (progn ,@body))
|
||
;; The first overlay is the shallowest. Any overlays created
|
||
;; while the first one is still being created go deeper and
|
||
;; deeper.
|
||
(sx--overlay-printing-depth (1+ sx--overlay-printing-depth)))
|
||
(let ((ov (make-overlay p (point)))
|
||
(props ,properties))
|
||
(while props
|
||
(overlay-put ov (pop props) (pop props)))
|
||
;; Let's multiply by 10 just in case we ever want to put
|
||
;; something in the middle.
|
||
(overlay-put ov 'priority (* 10 sx--overlay-printing-depth))
|
||
(push ov sx--overlays))
|
||
result))
|
||
|
||
(defun sx--recursive-replace (alist string)
|
||
"Replace each car of ALIST with its cdr in STRING."
|
||
(if alist
|
||
(sx--recursive-replace
|
||
(cdr alist)
|
||
(let ((kar (car alist)))
|
||
(replace-regexp-in-string
|
||
(format "[%s]" (car kar)) (cdr kar) string)))
|
||
string))
|
||
|
||
(defun sx-format-replacements (format alist &optional property-alist)
|
||
"Use FORMAT-STRING to format the values in ALIST.
|
||
ALIST is a list with elements of the form (CHAR . STRING).
|
||
The value is a copy of FORMAT-STRING, but with certain constructs
|
||
replaced by text as given by ALIST.
|
||
|
||
The construct is a `%' character followed by any other character.
|
||
The replacement is the STRING corresponding to CHAR in ALIST. In
|
||
addition, if CHAR is also the car of an element in
|
||
PROPERTY-ALIST, the cdr of that element should be a list of text
|
||
properties which will be applied on the replacement.
|
||
|
||
The %% construct is special, it is replaced with a single %, even
|
||
if ALIST contains a different string at the ?% entry."
|
||
(let ((alist (cons '(?% . "%") alist)))
|
||
(with-temp-buffer
|
||
(insert format)
|
||
(goto-char (point-min))
|
||
(while (search-forward-regexp
|
||
(rx "%" (group-n 1 (* (any "-+ #0-9.")))) nil 'noerror)
|
||
(let* ((char (char-after))
|
||
;; Understand flags
|
||
(flag (match-string 1))
|
||
(val (cdr-safe (assq char alist))))
|
||
(unless val
|
||
(error "Invalid format character: `%%%c'" char))
|
||
;; Insert first, to preserve text properties.
|
||
(insert-and-inherit (format (concat "%" flag "s") val))
|
||
(when property-alist
|
||
(add-text-properties (match-end 0) (point)
|
||
(cdr-safe (assq char property-alist))))
|
||
;; Delete the specifier body.
|
||
(delete-region (match-beginning 0)
|
||
(match-end 0))
|
||
;; Delete `char-after'.
|
||
(delete-char 1)))
|
||
(buffer-string))))
|
||
|
||
|
||
;;; Key definitions
|
||
(defun sx--key-definitions-to-header-line (definitions)
|
||
"Return a `header-line-format' from DEFINITIONS.
|
||
DEFINITIONS is a list where each element has one of the following two forms
|
||
(KEY COMMAND)
|
||
(KEY COMMAND DESCRIPTION)
|
||
|
||
The latter are used to build the return value, the former are
|
||
ignored."
|
||
(let ((ptize (lambda (x) `(:propertize ,x face mode-line-buffer-id)))
|
||
alist out)
|
||
(dolist (it definitions)
|
||
(when (> (length it) 2)
|
||
(let* ((key (car it))
|
||
(desc (elt it 2))
|
||
(cell (assoc desc alist)))
|
||
(if cell (push key (cdr cell))
|
||
(push (cons desc (list key)) alist)))))
|
||
(dolist (it alist out)
|
||
(let ((desc (car it))
|
||
(keys (cdr it)))
|
||
(push (list " "
|
||
(cons (funcall ptize (car keys))
|
||
(mapcar (lambda (k) `("," ,(funcall ptize k))) (cdr keys)))
|
||
(let ((match
|
||
(and (= 1 (length keys))
|
||
(string-match (regexp-quote (car keys)) desc))))
|
||
(if (and (numberp match) (= 0 match))
|
||
(substring desc (length (car keys)))
|
||
(concat ":" desc))))
|
||
out)))))
|
||
|
||
|
||
(defcustom sx-init-hook nil
|
||
"Hook run when SX initializes.
|
||
Run after `sx-init--internal-hook'."
|
||
:group 'sx
|
||
:type 'hook)
|
||
|
||
(defvar sx-init--internal-hook nil
|
||
"Hook run when SX initializes.
|
||
This is used internally to set initial values for variables such
|
||
as filters.")
|
||
|
||
(defmacro sx-init-variable (variable value &optional setter)
|
||
"Set VARIABLE to VALUE using SETTER.
|
||
SETTER should be a function of two arguments. If SETTER is nil,
|
||
`set' is used."
|
||
(eval
|
||
`(add-hook
|
||
'sx-init--internal-hook
|
||
(lambda ()
|
||
(,(or setter #'setq) ,variable ,value))))
|
||
nil)
|
||
|
||
(defvar sx-initialized nil
|
||
"Nil if sx hasn't been initialized yet.
|
||
If it has, holds the time at which initialization happened.")
|
||
|
||
(defun sx-initialize (&optional force)
|
||
"Run initialization hooks if they haven't been run yet.
|
||
These are `sx-init--internal-hook' and `sx-init-hook'.
|
||
|
||
If FORCE is non-nil, run them even if they've already been run."
|
||
(when (or force (not sx-initialized))
|
||
(prog1
|
||
(run-hooks 'sx-init--internal-hook
|
||
'sx-init-hook)
|
||
(setq sx-initialized (current-time)))))
|
||
|
||
(provide 'sx)
|
||
;;; sx.el ends here
|
||
|
||
;; Local Variables:
|
||
;; indent-tabs-mode: nil
|
||
;; End:
|