aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArtur Malabarba <bruce.connor.am@gmail.com>2015-03-26 20:27:39 +0000
committerArtur Malabarba <bruce.connor.am@gmail.com>2015-03-26 20:27:39 +0000
commit542bcc6a8be0dc5b28bfe43d7e954f4476c7f02a (patch)
tree1d0337b03364cfce2fd0b700d48c1200703c2e73
parente73dcda1ea1ed044f1ed83192e7e7dd7e1ce59e4 (diff)
parentce6600296875e17009e2b85c769956cde55a2d53 (diff)
Merge branch 'master' into more-ordering
-rw-r--r--sx-button.el34
-rw-r--r--sx-compose.el19
-rw-r--r--sx-filter.el3
-rw-r--r--sx-inbox.el6
-rw-r--r--sx-interaction.el65
-rw-r--r--sx-method.el28
-rw-r--r--sx-question-list.el113
-rw-r--r--sx-question-mode.el132
-rw-r--r--sx-question-print.el453
-rw-r--r--sx-question.el6
-rw-r--r--sx-request.el58
-rw-r--r--sx-search.el20
-rw-r--r--sx-tag.el38
-rw-r--r--sx.el56
-rw-r--r--test/test-api.el23
-rw-r--r--test/test-printing.el26
16 files changed, 770 insertions, 310 deletions
diff --git a/sx-button.el b/sx-button.el
index 5a2f052..2292ac9 100644
--- a/sx-button.el
+++ b/sx-button.el
@@ -77,30 +77,35 @@ This is usually a link's URL, or the content of a code block."
(point) 'sx-button-copy-type)
content)))))
-(defun sx-button-edit-this (text-or-marker &optional major-mode)
- "Open a temp buffer populated with the string TEXT-OR-MARKER using MAJOR-MODE.
+(defun sx-button-edit-this (text-or-marker &optional majormode)
+ "Open a temp buffer populated with the string TEXT-OR-MARKER using MAJORMODE.
When given a marker (or interactively), use the 'sx-button-copy
and the 'sx-mode text-properties under the marker. These are
usually part of a code-block."
(interactive (list (point-marker)))
;; Buttons receive markers.
(when (markerp text-or-marker)
- (setq major-mode (get-text-property text-or-marker 'sx-mode))
+ (setq majormode (get-text-property text-or-marker 'sx-mode))
(unless (setq text-or-marker
(get-text-property text-or-marker 'sx-button-copy))
(sx-message "Nothing of interest here.")))
(with-current-buffer (pop-to-buffer (generate-new-buffer
"*sx temp buffer*"))
(insert text-or-marker)
- (when major-mode
- (funcall major-mode))))
+ (when majormode
+ (funcall majormode))))
(defun sx-button-follow-link (&optional pos)
"Follow link at POS. If POS is nil, use `point'."
(interactive)
- (browse-url
- (or (get-text-property (or pos (point)) 'sx-button-url)
- (sx-user-error "No url under point: %s" (or pos (point))))))
+ (let ((url (or (get-text-property (or pos (point)) 'sx-button-url)
+ (sx-user-error "No url under point: %s" (or pos (point))))))
+ ;; If we didn't recognize the link, this errors immediately. If
+ ;; we mistakenly recognize it, it will error when we try to fetch
+ ;; whatever we thought it was.
+ (condition-case nil (sx-open-link url)
+ ;; When it errors, don't blame the user, just visit externally.
+ (error (browse-url url)))))
;;; Help-echo definitions
@@ -117,6 +122,12 @@ usually part of a code-block."
"link")
"Help echoed in the minibuffer when point is on a user.")
+(defconst sx-button--tag-help-echo
+ (format sx-button--help-echo
+ "Tag search"
+ "tag")
+ "Help echoed in the minibuffer when point is on a tag.")
+
(defconst sx-button--question-title-help-echo
(format sx-button--help-echo
"hide content"
@@ -158,6 +169,13 @@ usually part of a code-block."
'face 'sx-user-name
:supertype 'sx-button)
+(declare-function sx-search-tag-at-point "sx-search")
+(define-button-type 'sx-button-tag
+ 'action #'sx-search-tag-at-point
+ 'help-echo sx-button--tag-help-echo
+ 'face 'sx-tag
+ :supertype 'sx-button)
+
(define-button-type 'sx-button-comment
'help-echo (concat "mouse-1, RET"
(propertize ": write a comment"
diff --git a/sx-compose.el b/sx-compose.el
index eb5e2eb..e3f9c00 100644
--- a/sx-compose.el
+++ b/sx-compose.el
@@ -193,8 +193,7 @@ tags. Return a list of already inserted tags."
'noerror)
(error "No Tags header found"))
(save-match-data
- (split-string (match-string 1) (rx (any space ",;"))
- 'omit-nulls (rx space))))
+ (sx--split-string (match-string 1) (rx (any space ",;")))))
(defun sx-compose--check-tags ()
"Check if tags in current compose buffer are valid."
@@ -295,15 +294,14 @@ Keywords meant to be used in `sx-method-call'.
`body' is read as the `buffer-string'. If IS-QUESTION is non-nil,
other keywords are read from the header "
+ (goto-char (point-min))
`(,@(when is-question
(let ((inhibit-point-motion-hooks t)
- (inhibit-read-only t)
(header-end
(next-single-property-change
(point-min) 'sx-compose-separator))
keywords)
;; Read the Title.
- (goto-char (point-min))
(unless (search-forward-regexp
"^Title: *\\(.*\\) *$" header-end 'noerror)
(error "No Title header found"))
@@ -313,16 +311,13 @@ other keywords are read from the header "
(unless (search-forward-regexp "^Tags : *\\([^[:space:]].*\\) *$"
header-end 'noerror)
(error "No Tags header found"))
- (push (cons 'tags (split-string (match-string 1)
- "[[:space:],;]" 'omit-nulls))
+ (push (cons 'tags (sx--split-string (match-string 1) "[[:space:],;]"))
keywords)
- ;; And erase the header so it doesn't get sent.
- (delete-region
- (point-min)
- (next-single-property-change
- header-end 'sx-compose-separator))
+ ;; And move past the header so it doesn't get sent.
+ (goto-char (next-single-property-change
+ header-end 'sx-compose-separator))
keywords))
- (body . ,(buffer-string))))
+ (body . ,(buffer-substring-no-properties (point) (point-max)))))
(defun sx-compose--get-buffer-create (site data)
"Get or create a buffer for use with `sx-compose-mode'.
diff --git a/sx-filter.el b/sx-filter.el
index 1ccf611..5848e34 100644
--- a/sx-filter.el
+++ b/sx-filter.el
@@ -111,6 +111,9 @@ return the compiled filter."
bounty_amount
comments
creation_date
+ closed_reason
+ closed_date
+ closed_details
answers
answer_count
score
diff --git a/sx-inbox.el b/sx-inbox.el
index 21589fb..3048509 100644
--- a/sx-inbox.el
+++ b/sx-inbox.el
@@ -127,11 +127,7 @@ These are identified by their links.")
(setq tabulated-list-format
[("Type" 30 t nil t) ("Date" 10 t :right-align t) ("Title" 0)])
(setq mode-line-format sx-inbox--mode-line)
- (setq header-line-format sx-inbox--header-line)
- ;; @TODO: This will no longer be necessary once we properly
- ;; refactor sx-question-list-mode.
- (remove-hook 'tabulated-list-revert-hook
- #'sx-question-list--update-mode-line t))
+ (setq header-line-format sx-inbox--header-line))
;;; Keybinds
diff --git a/sx-interaction.el b/sx-interaction.el
index 3d60cbe..8754c54 100644
--- a/sx-interaction.el
+++ b/sx-interaction.el
@@ -44,6 +44,7 @@
(require 'sx-question-mode)
(require 'sx-question-list)
(require 'sx-compose)
+(require 'sx-cache)
;;; Using data in buffer
@@ -105,6 +106,18 @@ Only fields contained in TO are copied."
(setcar to (car from))
(setcdr to (cdr from)))
+(defun sx-ensure-authentication ()
+ "Signal user-error if the user refuses to authenticate.
+Note that `sx-method-call' already does authentication checking.
+This function is meant to be used by commands that don't
+immediately perform method calls, such as `sx-ask'. This way,
+the unauthenticated user will be prompted before going through
+the trouble of composing an entire question."
+ (unless (sx-cache-get 'auth)
+ (if (y-or-n-p "This command requires authentication, would you like to authenticate? ")
+ (sx-authenticate)
+ (sx-user-error "This command requires authentication, please run `M-x sx-authenticate' and try again."))))
+
;;; Visiting
(defun sx-visit-externally (data &optional copy-as-kill)
@@ -154,9 +167,8 @@ Element can be a question, answer, or comment."
(question
(sx-display-question
(sx-question-get-question .site_par .id) 'focus))
- (t (sx-message
- "Don't know how to open this link, please file a bug report: %s"
- link)
+ (t (error "Don't know how to open this link, please file a bug report: %s"
+ link)
nil))))))
@@ -230,14 +242,7 @@ Interactively, it is guessed from context at point.
With the UNDO prefix argument, unfavorite the question instead."
(interactive (list (sx--error-if-unread (sx--data-here 'question))
current-prefix-arg))
- (sx-assoc-let data
- (sx-method-call 'questions
- :id .question_id
- :submethod (if undo 'favorite/undo 'favorite)
- :auth 'warn
- :site .site_par
- :url-method 'post
- :filter sx-browse-filter)))
+ (sx-method-post-from-data data (if undo 'favorite/undo 'favorite)))
(defalias 'sx-star #'sx-favorite)
@@ -268,18 +273,8 @@ DATA can be a question, answer, or comment. TYPE can be
Besides posting to the api, DATA is also altered to reflect the
changes."
(let ((result
- (sx-assoc-let data
- (sx-method-call
- (cond
- (.comment_id "comments")
- (.answer_id "answers")
- (.question_id "questions"))
- :id (or .comment_id .answer_id .question_id)
- :submethod (concat type (unless status "/undo"))
- :auth 'warn
- :url-method 'post
- :filter sx-browse-filter
- :site .site_par))))
+ (sx-method-post-from-data
+ data (concat type (unless status "/undo")))))
;; The api returns the new DATA.
(when (> (length result) 0)
(sx--copy-data (elt result 0) data)
@@ -287,6 +282,26 @@ changes."
(sx--maybe-update-display))))
+;;; Delete
+(defun sx-delete (data &optional undo)
+ "Delete an object given by DATA.
+DATA can be a question, answer, or comment. Interactively, it is
+guessed from context at point.
+With UNDO prefix argument, undelete instead."
+ (interactive (list (sx--error-if-unread (sx--data-here))
+ current-prefix-arg))
+ (when (y-or-n-p (format "DELETE this %s? "
+ (let-alist data
+ (cond (.comment_id "comment")
+ (.answer_id "answer")
+ (.question_id "question")))))
+ (sx-method-post-from-data data (if undo 'delete/undo 'delete))
+ ;; Indicate to ourselves this has been deleted.
+ (setcdr data (cons (car data) (cdr data)))
+ (setcar data 'deleted)
+ (sx--maybe-update-display)))
+
+
;;; Commenting
(defun sx-comment (data &optional text)
"Post a comment on DATA given by TEXT.
@@ -296,6 +311,7 @@ If DATA is a comment, the comment is posted as a reply to it.
TEXT is a string. Interactively, it is read from the minibufer."
(interactive (list (sx--error-if-unread (sx--data-here)) 'query))
+ (sx-ensure-authentication)
;; When clicking the "Add a Comment" button, first arg is a marker.
(when (markerp data)
(setq data (sx--data-here))
@@ -393,6 +409,7 @@ OBJECT can be a question or an answer."
DATA is an answer or question alist. Interactively, it is guessed
from context at point."
(interactive (list (sx--data-here)))
+ (sx-ensure-authentication)
;; If we ever make an "Edit" button, first arg is a marker.
(when (markerp data) (setq data (sx--data-here)))
(sx-assoc-let data
@@ -441,6 +458,7 @@ If nil, use `sx--interactive-site-prompt' anyway."
"Start composing a question for SITE.
SITE is a string, indicating where the question will be posted."
(interactive (list (sx--interactive-site-prompt)))
+ (sx-ensure-authentication)
(let ((buffer (current-buffer)))
(pop-to-buffer
(sx-compose-create
@@ -458,6 +476,7 @@ context at point. "
;; probaby hit the button by accident.
(interactive
(list (sx--error-if-unread (sx--data-here 'question))))
+ (sx-ensure-authentication)
;; When clicking the "Write an Answer" button, first arg is a marker.
(when (markerp data) (setq data (sx--data-here)))
(let ((buffer (current-buffer)))
diff --git a/sx-method.el b/sx-method.el
index 9d61e60..f2e68b3 100644
--- a/sx-method.el
+++ b/sx-method.el
@@ -142,6 +142,34 @@ Return the entire response as a complex alist."
url-method
(or get-all process-function))))
+(defun sx-method-post-from-data (data &rest keys)
+ "Make a POST `sx-method-call', deriving parameters from DATA.
+KEYS are [KEYWORD VALUE] pairs passed to `sx-method-call', except
+the following which are decided by this function:
+
+ METHOD :site and :id are derived from DATA, where METHOD is
+ either \"answers\", \"comments\", or \"questions\".
+ :url-method is post.
+ :filter is `sx-browse-filter'.
+ :auth is warn.
+
+As a special exception, if KEYS is a single argument, it is
+assumed to be the :submethod argument."
+ (declare (indent 1))
+ (sx-assoc-let data
+ (apply #'sx-method-call
+ (cond (.comment_id "comments")
+ (.answer_id "answers")
+ (.question_id "questions"))
+ :id (or .comment_id .answer_id .question_id)
+ :auth 'warn
+ :url-method 'post
+ :filter sx-browse-filter
+ :site .site_par
+ (if (= 1 (length keys))
+ (cons :submethod keys)
+ keys))))
+
(provide 'sx-method)
;;; sx-method.el ends here
diff --git a/sx-question-list.el b/sx-question-list.el
index 5812ff2..f8f8fc6 100644
--- a/sx-question-list.el
+++ b/sx-question-list.el
@@ -27,6 +27,7 @@
(require 'sx)
(require 'sx-time)
+(require 'sx-tag)
(require 'sx-site)
(require 'sx-question)
(require 'sx-question-mode)
@@ -81,11 +82,6 @@
""
:group 'sx-question-list-faces)
-(defface sx-question-list-tags
- '((t :inherit sx-question-mode-tags))
- ""
- :group 'sx-question-list-faces)
-
(defface sx-question-list-date
'((t :inherit font-lock-comment-face))
""
@@ -170,8 +166,7 @@ Also see `sx-question-list-refresh'."
" "
;; @TODO: Make this width customizable. (Or maybe just make
;; the whole thing customizable)
- (propertize (format "%-40s" (mapconcat #'sx-question--tag-format .tags " "))
- 'face 'sx-question-list-tags)
+ (format "%-40s" (sx-tag--format-tags .tags sx-question-list--site))
" "
(sx-user--format "%15d %4r" .owner)
(propertize " " 'display "\n")))))))
@@ -215,19 +210,39 @@ and thus not displayed in the list of questions.
This is ignored if `sx-question-list--refresh-function' is set.")
(make-variable-buffer-local 'sx-question-list--dataset)
+(defconst sx-question-list--key-definitions
+ '(
+ ;; S-down and S-up would collide with `windmove'.
+ ("<down>" sx-question-list-next)
+ ("<up>" sx-question-list-previous)
+ ("RET" sx-display "Display")
+ ("n" sx-question-list-next "Navigate")
+ ("p" sx-question-list-previous "Navigate")
+ ("j" sx-question-list-view-next "Navigate")
+ ("k" sx-question-list-view-previous "Navigate")
+ ("N" sx-question-list-next-far)
+ ("P" sx-question-list-previous-far)
+ ("J" sx-question-list-next-far)
+ ("K" sx-question-list-previous-far)
+ ("g" sx-question-list-refresh)
+ ("t" sx-tab-switch "tab")
+ ("a" sx-ask "ask")
+ ("S" sx-search "Search")
+ ("s" sx-switchto-map "switch-to")
+ ("v" sx-visit-externally "visit")
+ ("u" sx-upvote)
+ ("d" sx-downvote)
+ ("h" sx-question-list-hide "hide")
+ ("m" sx-question-list-mark-read "mark-read")
+ ("*" sx-favorite)
+ )
+ "List of key definitions for `sx-question-list-mode'.
+This list must follow the form described in
+`sx--key-definitions-to-header-line'.")
+
(defconst sx-question-list--header-line
- '(" "
- (:propertize "n p j k" face mode-line-buffer-id)
- ": Navigate"
- " "
- (:propertize "RET" face mode-line-buffer-id)
- ": View question"
- " "
- (:propertize "v" face mode-line-buffer-id)
- ": Visit externally"
- " "
- (:propertize "q" face mode-line-buffer-id)
- ": Quit")
+ (sx--key-definitions-to-header-line
+ sx-question-list--key-definitions)
"Header-line used on the question list.")
(defvar sx-question-list--order-methods
@@ -321,7 +336,8 @@ into consideration. The same holds for `sx-question-list--order'.
\\{sx-question-list-mode-map}"
(hl-line-mode 1)
- (sx-question-list--update-mode-line)
+ (setq mode-line-format
+ sx-question-list--mode-line-format)
(setq sx-question-list--pages-so-far 0)
(setq tabulated-list-format
[(" V" 3 t :right-align t)
@@ -333,8 +349,6 @@ into consideration. The same holds for `sx-question-list--order'.
(setq tabulated-list-sort-key nil)
(add-hook 'tabulated-list-revert-hook
#'sx-question-list-refresh nil t)
- (add-hook 'tabulated-list-revert-hook
- #'sx-question-list--update-mode-line nil t)
(setq header-line-format sx-question-list--header-line))
(defcustom sx-question-list-date-sort-method 'last_activity_date
@@ -351,34 +365,10 @@ into consideration. The same holds for `sx-question-list--order'.
;;; Keybinds
-(mapc
- (lambda (x) (define-key sx-question-list-mode-map
- (car x) (cadr x)))
- '(
- ;; S-down and S-up would collide with `windmove'.
- ([down] sx-question-list-next)
- ([up] sx-question-list-previous)
- ("n" sx-question-list-next)
- ("p" sx-question-list-previous)
- ("j" sx-question-list-view-next)
- ("k" sx-question-list-view-previous)
- ("N" sx-question-list-next-far)
- ("P" sx-question-list-previous-far)
- ("J" sx-question-list-next-far)
- ("K" sx-question-list-previous-far)
- ("g" sx-question-list-refresh)
- ("t" sx-tab-switch)
- ("a" sx-ask)
- ("S" sx-search)
- ("s" sx-switchto-map)
- ("v" sx-visit-externally)
- ("u" sx-upvote)
- ("d" sx-downvote)
- ("h" sx-question-list-hide)
- ("m" sx-question-list-mark-read)
- ("*" sx-favorite)
- ([?\r] sx-display)
- ))
+;; We need this quote+eval combo because `kbd' was a macro in 24.2.
+(mapc (lambda (x) (eval `(define-key sx-question-list-mode-map
+ (kbd ,(car x)) #',(cadr x))))
+ sx-question-list--key-definitions)
(sx--define-conditional-key sx-question-list-mode-map "O" #'sx-question-list-order-by
(and (boundp 'sx-question-list--order) sx-question-list--order))
@@ -416,14 +406,12 @@ Non-interactively, DATA is a question alist."
;; "Unanswered", etc.
"Variable describing current tab being viewed.")
-(defvar sx-question-list--total-count 0
- "Holds the total number of questions in the current buffer.")
-(make-variable-buffer-local 'sx-question-list--total-count)
-
(defconst sx-question-list--mode-line-format
- '(" "
- mode-name
- " "
+ '(" "
+ (:propertize
+ (:eval (sx--pretty-site-parameter sx-question-list--site))
+ face mode-line-buffer-id)
+ " " mode-name ": "
(:propertize sx-question-list--current-tab
face mode-line-buffer-id)
" ["
@@ -434,7 +422,7 @@ Non-interactively, DATA is a question alist."
", "
"Total: "
(:propertize
- (:eval (int-to-string sx-question-list--total-count))
+ (:eval (int-to-string (length tabulated-list-entries)))
face mode-line-buffer-id)
"] ")
"Mode-line construct to use in question-list buffers.")
@@ -445,15 +433,6 @@ Non-interactively, DATA is a question alist."
(cl-count-if-not
#'sx-question--read-p sx-question-list--dataset)))
-(defun sx-question-list--update-mode-line ()
- "Fill the mode-line with useful information."
- ;; All the data we need is right in the buffer.
- (when (derived-mode-p 'sx-question-list-mode)
- (setq mode-line-format
- sx-question-list--mode-line-format)
- (setq sx-question-list--total-count
- (length tabulated-list-entries))))
-
(defvar sx-question-list--site nil
"Site being displayed in the *question-list* buffer.")
(make-variable-buffer-local 'sx-question-list--site)
diff --git a/sx-question-mode.el b/sx-question-mode.el
index 6125416..561ae23 100644
--- a/sx-question-mode.el
+++ b/sx-question-mode.el
@@ -48,6 +48,7 @@ Common values for this variable are `pop-to-buffer' and `switch-to-buffer'."
(defvar sx-question-mode--data nil
"The data of the question being displayed.")
+(make-variable-buffer-local 'sx-question-mode--data)
(defun sx-question-mode--get-window ()
"Return a window displaying a question, or nil."
@@ -69,6 +70,7 @@ Returns the question buffer."
(defun sx-question-mode--erase-and-print-question (data)
"Erase contents of buffer and print question given by DATA.
Also marks the question as read with `sx-question--mark-read'."
+ (sx--ensure-site data)
(sx-question--mark-read data)
(let ((inhibit-read-only t))
(erase-buffer)
@@ -161,72 +163,98 @@ property."
pos 'sx-question-mode--section-content nil)))
-;;; Major-mode
+;;; Major-mode constants
+(defconst sx-question-mode--key-definitions
+ '(
+ ("<down>" sx-question-mode-next-section)
+ ("<up>" sx-question-mode-previous-section)
+ ("n" sx-question-mode-next-section "Navigate")
+ ("p" sx-question-mode-previous-section "Navigate")
+ ("g" sx-question-mode-refresh)
+ ("v" sx-visit-externally)
+ ("u" sx-upvote "upvote")
+ ("d" sx-downvote "downvote")
+ ("q" quit-window)
+ ("SPC" scroll-up-command)
+ ("e" sx-edit "edit")
+ ("S" sx-search)
+ ("*" sx-favorite "star")
+ ("K" sx-delete "Delete")
+ ("s" sx-switchto-map "switch-to")
+ ("O" sx-question-mode-order-by "Order")
+ ("c" sx-comment "comment")
+ ("a" sx-answer "answer")
+ ("TAB" forward-button "Navigate")
+ ("<S-iso-lefttab>" backward-button)
+ ("<S-tab>" backward-button)
+ ("<backtab>" backward-button))
+ "List of key definitions for `sx-question-mode'.
+This list must follow the form described in
+`sx--key-definitions-to-header-line'.")
+
(defconst sx-question-mode--header-line
- '(" "
- (:propertize "n p TAB" face mode-line-buffer-id)
- ": Navigate"
- " "
- (:propertize "u d" face mode-line-buffer-id)
- ": Up/Down Vote"
- " "
- (:propertize "c" face mode-line-buffer-id)
- ": Comment"
- " "
- (:propertize "a" face mode-line-buffer-id)
- ": Answer"
- " "
- (:propertize "e" face mode-line-buffer-id)
- ": Edit"
- " "
- (:propertize "q" face mode-line-buffer-id)
- ": Quit")
+ (sx--key-definitions-to-header-line
+ sx-question-mode--key-definitions)
"Header-line used on the question list.")
+
+;;; Major-mode definition
+(defconst sx-question-mode--mode-line
+ '(" "
+ ;; `sx-question-mode--data' is guaranteed to have through
+ ;; `sx--ensure-site' already, so we use `let-alist' instead of
+ ;; `sx-assoc-let' to improve performance (since the mode-line is
+ ;; updated a lot).
+ (:propertize
+ (:eval (sx--pretty-site-parameter
+ (let-alist sx-question-mode--data .site_par)))
+ face mode-line-buffer-id)
+ " " mode-name
+ " ["
+ "Answers: "
+ (:propertize
+ (:eval (number-to-string (let-alist sx-question-mode--data .answer_count)))
+ face mode-line-buffer-id)
+ ", "
+ "Stars: "
+ (:propertize
+ (:eval (number-to-string (or (let-alist sx-question-mode--data .favorite_count) 0)))
+ face mode-line-buffer-id)
+ ", "
+ "Views: "
+ (:propertize
+ (:eval (number-to-string (let-alist sx-question-mode--data .view_count)))
+ face mode-line-buffer-id)
+ "] ")
+ "Mode-line construct to use in `sx-question-mode' buffers.")
+
(define-derived-mode sx-question-mode special-mode "Question"
"Major mode to display and navigate a question and its answers.
Letters do not insert themselves; instead, they are commands.
+Don't activate this mode directly. Instead, to print a question
+on the current buffer use
+`sx-question-mode--erase-and-print-question'.
+
\\<sx-question-mode>
\\{sx-question-mode}"
(setq header-line-format sx-question-mode--header-line)
+ (setq mode-line-format sx-question-mode--mode-line)
;; Determine how to close this window.
(unless (window-parameter nil 'quit-restore)
(set-window-parameter
nil 'quit-restore
`(other window nil ,(current-buffer))))
- ;; We call font-lock-region manually. See `sx-question-mode--fill-and-fontify'
+ ;; We call font-lock-region manually. See `sx-question-mode--insert-markdown'.
(font-lock-mode -1)
(remove-hook 'after-change-functions 'markdown-check-change-for-wiki-link t)
(remove-hook 'window-configuration-change-hook
'markdown-fontify-buffer-wiki-links t))
-(mapc
- (lambda (x) (define-key sx-question-mode-map
- (car x) (cadr x)))
- `(
- ([down] sx-question-mode-next-section)
- ([up] sx-question-mode-previous-section)
- ("n" sx-question-mode-next-section)
- ("p" sx-question-mode-previous-section)
- ("g" sx-question-mode-refresh)
- ("c" sx-comment)
- ("v" sx-visit-externally)
- ("u" sx-upvote)
- ("d" sx-downvote)
- ("q" quit-window)
- (" " scroll-up-command)
- ("a" sx-answer)
- ("e" sx-edit)
- ("S" sx-search)
- ("s" sx-switchto-map)
- ("*" sx-favorite)
- (,(kbd "S-SPC") scroll-down-command)
- ([backspace] scroll-down-command)
- ([tab] forward-button)
- (,(kbd "<S-iso-lefttab>") backward-button)
- (,(kbd "<S-tab>") backward-button)
- (,(kbd "<backtab>") backward-button)))
+;; We need this quote+eval combo because `kbd' was a macro in 24.2.
+(mapc (lambda (x) (eval `(define-key sx-question-mode-map
+ (kbd ,(car x)) #',(cadr x))))
+ sx-question-mode--key-definitions)
(defun sx-question-mode-refresh (&optional no-update)
"Refresh currently displayed question.
@@ -256,6 +284,18 @@ query the api."
(unless (derived-mode-p 'sx-question-mode)
(error "Not in `sx-question-mode'")))
+(defun sx-question-mode-order-by (sort)
+ "Order answers in the current buffer by the method SORT.
+Sets `sx-question-list--order' and then calls
+`sx-question-list-refresh' with `redisplay'."
+ (interactive
+ (list (let ((order (sx-completing-read "Order answers by: "
+ (mapcar #'car sx-question-mode--sort-methods))))
+ (cdr-safe (assoc-string order sx-question-mode--sort-methods)))))
+ (when (and sort (functionp sort))
+ (setq sx-question-mode-answer-sort-function sort)
+ (sx-question-mode-refresh 'no-update)))
+
(provide 'sx-question-mode)
;;; sx-question-mode.el ends here
diff --git a/sx-question-print.el b/sx-question-print.el
index 778b580..7f312eb 100644
--- a/sx-question-print.el
+++ b/sx-question-print.el
@@ -63,7 +63,7 @@ Some faces of this mode might be defined in the `sx-user' group."
:type 'string
:group 'sx-question-mode)
-(defcustom sx-question-mode-header-author-format "\nAuthor: %d %r"
+(defcustom sx-question-mode-header-author-format "\nAuthor: %d %r"
"String used to display the question author at the header.
% constructs have special meaning here. See `sx-user--format'."
:type 'string
@@ -74,16 +74,11 @@ Some faces of this mode might be defined in the `sx-user' group."
"Face used on the question date in the question buffer."
:group 'sx-question-mode-faces)
-(defcustom sx-question-mode-header-date "\nAsked on: "
+(defcustom sx-question-mode-header-date "\nPosted on: "
"String used before the question date at the header."
:type 'string
:group 'sx-question-mode)
-(defface sx-question-mode-tags
- '((t :underline nil :inherit font-lock-function-name-face))
- "Face used on the question tags in the question buffer."
- :group 'sx-question-mode-faces)
-
(defface sx-question-mode-score
'((t))
"Face used for the score in the question buffer."
@@ -100,12 +95,17 @@ Some faces of this mode might be defined in the `sx-user' group."
"Face used for downvoted score in the question buffer."
:group 'sx-question-mode-faces)
-(defcustom sx-question-mode-header-tags "\nTags: "
+(defface sx-question-mode-sub-sup
+ '((t :height 0.7))
+ "Face used on <sub> and <sup> tags."
+ :group 'sx-question-mode-faces)
+
+(defcustom sx-question-mode-header-tags "\nTags: "
"String used before the question tags at the header."
:type 'string
:group 'sx-question-mode)
-(defcustom sx-question-mode-header-score "\nScore: "
+(defcustom sx-question-mode-header-score "\nScore: "
"String used before the question score at the header."
:type 'string
:group 'sx-question-mode)
@@ -126,7 +126,7 @@ the editor's name."
:group 'sx-question-mode)
(defcustom sx-question-mode-separator
- (concat (make-string 80 ?_) "\n")
+ (concat (make-string 69 ?_) "\n")
"Separator used between header and body."
:type 'string
:group 'sx-question-mode)
@@ -136,6 +136,30 @@ the editor's name."
:type 'string
:group 'sx-question-mode)
+(defface sx-question-mode-accepted
+ '((t :foreground "ForestGreen" :inherit sx-question-mode-title))
+ "Face used for accepted answers in the question buffer."
+ :group 'sx-question-mode-faces)
+
+(defface sx-question-mode-closed
+ '((t :box 2 :inherit font-lock-warning-face))
+ "Face used for closed question header in the question buffer."
+ :group 'sx-question-mode-faces)
+
+(defface sx-question-mode-closed-reason
+ `((t :box (:line-width 2 :color ,(face-attribute 'sx-question-mode-closed
+ :foreground nil t))
+ :inherit sx-question-mode-title))
+ "Face used for closed question header in the question buffer.
+Aesthetically, it's important that the color of this face's :box
+attribute match the color of the face `sx-question-mode-closed'."
+ :group 'sx-question-mode-faces)
+
+(defcustom sx-question-mode-answer-accepted-title "Accepted Answer"
+ "Title used at the start of accepted \"Answer\" section."
+ :type 'string
+ :group 'sx-question-mode)
+
(defcustom sx-question-mode-comments-title " Comments"
"Title used at the start of \"Comments\" sections."
:type 'string
@@ -153,62 +177,132 @@ replaced with the comment."
:type 'boolean
:group 'sx-question-mode)
+(defconst sx-question-mode--sort-methods
+ (let ((methods
+ '(("Higher-scoring" . sx-answer-higher-score-p)
+ ("Newer" . sx-answer-newer-p)
+ ("More active" . sx-answer-more-active-p))))
+ (append (mapcar (lambda (x) (cons (concat (car x) " first") (cdr x)))
+ methods)
+ (mapcar (lambda (x) (cons (concat (car x) " last")
+ (sx--invert-predicate (cdr x))))
+ methods))))
+
(defcustom sx-question-mode-answer-sort-function
#'sx-answer-higher-score-p
"Function used to sort answers in the question buffer."
- :type '(choice
- (const :tag "Higher-scoring first" sx-answer-higher-score-p)
- (const :tag "Newer first" sx-answer-newer-p)
- (const :tag "More active first" sx-answer-more-active-p))
+ :type
+ (cons 'choice
+ (mapcar (lambda (x) `(const :tag ,(car x) ,(cdr x)))
+ sx-question-mode--sort-methods))
+ :group 'sx-question-mode)
+
+(defcustom sx-question-mode-use-images
+ (eval-when-compile
+ (image-type-available-p 'imagemagick))
+ "Non-nil if SX should download and display images.
+By default, this is `t' if the `imagemagick' image type is
+available (checked with `image-type-available-p'). If this image
+type is not available, images won't work."
+ :type 'boolean
+ :group 'sx-question-mode)
+
+(defcustom sx-question-mode-image-max-width 550
+ "Maximum width, in pixels, of images in the question buffer."
+ :type 'integer
:group 'sx-question-mode)
;;; Functions
;;;; Printing the general structure
+(defconst sx-question-mode--closed-mode-line-string
+ '(:propertize " [CLOSED] " face font-lock-warning-face)
+ "String indicating closed questions in the mode-line.")
+
(defun sx-question-mode--print-question (question)
"Print a buffer describing QUESTION.
QUESTION must be a data structure returned by `json-read'."
+ (when (sx--deleted-p question)
+ (sx-user-error "This is a deleted question"))
(setq sx-question-mode--data question)
;; Clear the overlays
(mapc #'delete-overlay sx--overlays)
(setq sx--overlays nil)
;; Print everything
- (sx-question-mode--print-section question)
(sx-assoc-let question
+ (when .closed_reason
+ (add-to-list 'mode-line-format sx-question-mode--closed-mode-line-string)
+ (sx-question-mode--print-close-reason .closed_reason .closed_date .closed_details))
+ (sx-question-mode--print-section question)
(mapc #'sx-question-mode--print-section
- (cl-sort .answers sx-question-mode-answer-sort-function)))
+ (cl-remove-if
+ #'sx--deleted-p
+ (cl-sort .answers sx-question-mode-answer-sort-function))))
(insert "\n\n ")
(insert-text-button "Write an Answer" :type 'sx-button-answer)
;; Go up
(goto-char (point-min))
(sx-question-mode-next-section))
+(defun sx-question-mode--print-close-reason (reason date &optional details)
+ "Print a header explaining REASON and DATE.
+DATE is an integer.
+
+DETAILS, when given is an alist further describing the close."
+ (let ((l (point)))
+ (let-alist details
+ (insert "\n "
+ (propertize (format " %s as %s, %s ago. "
+ (if .on_hold "Put on hold" "Closed")
+ reason
+ (sx-time-since date))
+ 'face 'sx-question-mode-closed)
+ "\n")
+ (when .description
+ (insert (replace-regexp-in-string "<[^>]+>" "" .description)
+ "\n")))
+ (save-excursion
+ (goto-char l)
+ (search-forward " as " nil 'noerror)
+ (setq l (point))
+ (skip-chars-forward "^,")
+ (let ((ov (make-overlay l (point))))
+ (overlay-put ov 'face 'sx-question-mode-closed-reason)
+ (push ov sx--overlays)))))
+
(defun sx-question-mode--print-section (data)
"Print a section corresponding to DATA.
DATA can represent a question or an answer."
;; This makes `data' accessible through `sx--data-here'.
- (sx-assoc-let data
- (sx--wrap-in-overlay
- (list 'sx--data-here data)
+ (sx--wrap-in-overlay
+ (list 'sx--data-here data)
+ (sx-assoc-let data
(insert sx-question-mode-header-title)
(insert-text-button
;; Questions have title, Answers don't
- (or .title sx-question-mode-answer-title)
+ (cond (.title)
+ ((eq .is_accepted t) sx-question-mode-answer-accepted-title)
+ (t sx-question-mode-answer-title))
;; Section level
'sx-question-mode--section (if .title 1 2)
'sx-button-copy .share_link
+ 'face (if (eq .is_accepted t) 'sx-question-mode-accepted
+ 'sx-question-mode-title)
:type 'sx-question-mode-title)
+
;; Sections can be hidden with overlays
(sx--wrap-in-overlay
'(sx-question-mode--section-content t)
+
;; Author
(insert
(sx-user--format
(propertize sx-question-mode-header-author-format
'face 'sx-question-mode-header)
.owner))
+
+ ;; Date
(sx-question-mode--insert-header
- ;; Date
sx-question-mode-header-date
(concat
(sx-time-seconds-to-date .creation_date)
@@ -217,54 +311,60 @@ DATA can represent a question or an answer."
(sx-time-since .last_edit_date)
(sx-user--format "%d" .last_editor))))
'sx-question-mode-date)
+
+ ;; Score and upvoted/downvoted status.
(sx-question-mode--insert-header
sx-question-mode-header-score
- (format "%s" .score)
- (cond
- ((eq .upvoted t) 'sx-question-mode-score-upvoted)
- ((eq .downvoted t) 'sx-question-mode-score-downvoted)
- (t 'sx-question-mode-score)))
+ (format "%s%s" .score
+ (cond ((eq .upvoted t) "↑") ((eq .downvoted t) "↓") (t "")))
+ (cond ((eq .upvoted t) 'sx-question-mode-score-upvoted)
+ ((eq .downvoted t) 'sx-question-mode-score-downvoted)
+ (t 'sx-question-mode-score)))
+
+ ;; Tags
(when .title
;; Tags
(sx-question-mode--insert-header
sx-question-mode-header-tags
- (mapconcat #'sx-question--tag-format .tags " ")
- 'sx-question-mode-tags))
+ (sx-tag--format-tags .tags .site_par)
+ nil))
;; Body
(insert "\n"
(propertize sx-question-mode-separator
'face 'sx-question-mode-header))
(sx--wrap-in-overlay
'(face sx-question-mode-content-face)
+ (insert "\n")
+ (sx-question-mode--insert-markdown .body_markdown)
(insert "\n"
- (sx-question-mode--fill-and-fontify
- .body_markdown)
- "\n"
(propertize sx-question-mode-separator
'face 'sx-question-mode-header)))
- ;; Comments have their own `sx--data-here' property (so they can
- ;; be upvoted too).
- (when .comments
- (insert "\n")
- (insert-text-button
- sx-question-mode-comments-title
- 'face 'sx-question-mode-title-comments
- 'sx-question-mode--section 3
- 'sx-button-copy .share_link
- :type 'sx-question-mode-title)
- (sx--wrap-in-overlay
- '(sx-question-mode--section-content t)
+ ;; Clean up commments manually deleted. The `append' call is
+ ;; to ensure `comments' is a list and not a vector.
+ (let ((comments (cl-remove-if #'sx--deleted-p (append .comments nil))))
+ (when comments
(insert "\n")
+ (insert-text-button
+ sx-question-mode-comments-title
+ 'face 'sx-question-mode-title-comments
+ 'sx-question-mode--section 3
+ 'sx-button-copy .share_link
+ :type 'sx-question-mode-title)
(sx--wrap-in-overlay
- '(face sx-question-mode-content-face)
- (mapc #'sx-question-mode--print-comment .comments))
- ;; If there are comments, we want part of this margin to go
- ;; inside them, so the button get's placed beside the
- ;; "Comments" header when you hide them.
+ '(sx-question-mode--section-content t)
+ (insert "\n")
+ (sx--wrap-in-overlay
+ '(face sx-question-mode-content-face)
+ ;; Comments have their own `sx--data-here' property (so they can
+ ;; be upvoted too).
+ (mapc #'sx-question-mode--print-comment comments))
+ ;; If there are comments, we want part of this margin to go
+ ;; inside them, so the button get's placed beside the
+ ;; "Comments" header when you hide them.
+ (insert " ")))
+ ;; If there are no comments, we have to add this margin here.
+ (unless comments
(insert " ")))
- ;; If there are no comments, we have to add this margin here.
- (unless .comments
- (insert " "))
(insert " ")
;; This is where the "add a comment" button is printed.
(insert-text-button "Add a Comment"
@@ -286,10 +386,13 @@ The comment is indented, filled, and then printed according to
(format sx-question-mode-comments-format
(sx-user--format "%d" .owner)
(substring
- (sx-question-mode--fill-and-fontify
- ;; We fill with three spaces at the start, so the comment is
- ;; slightly indented.
- (concat " " (sx--squash-whitespace .body_markdown)))
+ ;; We use temp buffer, so that image overlays don't get
+ ;; inserted with the comment.
+ (with-temp-buffer
+ ;; We fill with three spaces at the start, so the comment is
+ ;; slightly indented.
+ (sx-question-mode--insert-markdown (concat " " (sx--squash-whitespace .body_markdown)))
+ (buffer-string))
;; Then we remove the spaces from the first line, since we'll
;; add the username there anyway.
3))))))
@@ -304,7 +407,10 @@ where `value' is given `face' as its face.
(while args
(insert
(propertize (pop args) 'face 'sx-question-mode-header)
- (propertize (pop args) 'face (pop args)))))
+ (let ((header (pop args))
+ (face (pop args)))
+ (if face (propertize header 'face face)
+ header)))))
;;;; Printing and Font-locking the content (body)
@@ -315,88 +421,203 @@ where `value' is given `face' as its face.
(defconst sx-question-mode--reference-regexp
(rx line-start (0+ blank) "[%s]:" (0+ blank)
- (group-n 1 (1+ (not blank))))
+ (group-n 1 (1+ (not (any blank "\n\r")))))
"Regexp used to find the url of labeled links.
E.g.:
[1]: https://...")
(defconst sx-question-mode--link-regexp
;; Done at compile time.
- (rx (or (and "[" (group-n 1 (1+ (not (any "]")))) "]"
+ (rx (or (and "[" (optional (group-n 6 "meta-")) "tag:"
+ (group-n 5 (+ (not (any " ]")))) "]")
+ (and (opt "!") "[" (group-n 1 (1+ (not (any "]")))) "]"
(or (and "(" (group-n 2 (1+ (not (any ")")))) ")")
(and "[" (group-n 3 (1+ (not (any "]")))) "]")))
- (group-n 4 (and (and "http" (opt "s") "://") ""
+ (group-n 4 (and "http" (opt "s") "://"
(>= 2 (any lower numeric "_%"))
"."
- (>= 2 (any lower numeric "/._%&#?=;"))))))
+ (>= 2 (any lower numeric "_%"))
+ (* (any lower numeric "-/._%&#?=;"))))))
"Regexp matching markdown links.")
-(defun sx-question-mode--fill-and-fontify (text)
- "Return TEXT filled according to `markdown-mode'."
- (with-temp-buffer
- (insert text)
- (delay-mode-hooks (markdown-mode))
- (font-lock-mode -1)
- (when sx-question-mode-bullet-appearance
- (font-lock-add-keywords ;; Bullet items.
- nil
- `((,(rx line-start (0+ blank) (group-n 1 (any "*+-")) blank)
- 1 '(face nil display ,sx-question-mode-bullet-appearance) prepend))))
- (font-lock-add-keywords ;; Highlight usernames.
- nil
- `((,(rx (or blank line-start)
- (group-n 1 (and "@" (1+ (not space))))
- symbol-end)
- 1 font-lock-builtin-face)))
- ;; Everything.
- (font-lock-fontify-region (point-min) (point-max))
- ;; Compact links.
- (sx-question-mode--process-links-in-buffer)
- ;; And now the filling
- (goto-char (point-min))
- (while (null (eobp))
- ;; Don't fill pre blocks.
- (unless (sx-question-mode--dont-fill-here)
- (let ((beg (point)))
- (skip-chars-forward "\r\n[:blank:]")
- (forward-paragraph)
- (fill-region beg (point)))))
- (replace-regexp-in-string "[[:blank:]]+\\'" "" (buffer-string))))
+(defun sx-question-mode--process-markdown-in-region (beg end)
+ "Process Markdown text between BEG and END.
+This does not do Markdown font-locking. Instead, it fills text,
+propertizes links, inserts images, cleans up html comments, and
+font-locks code-blocks according to mode."
+ ;; Paragraph filling
+ (let ((paragraph-start
+ "\f\\|[ \t]*$\\|[ \t]*[*+-] \\|[ \t]*[0-9]+\\.[ \t]\\|[ \t]*: ")
+ (paragraph-separate "\\(?:[ \t\f]*\\|.* \\)$")
+ (adaptive-fill-first-line-regexp "\\`[ \t]*>[ \t]*?\\'")
+ (adaptive-fill-function #'markdown-adaptive-fill-function))
+ (save-restriction
+ (narrow-to-region beg end)
+ ;; Compact links.
+ (sx-question-mode--process-links-in-buffer)
+ (sx-question-mode--process-html-tags (point-min) (point-max))
+ ;; And now the filling and other handlings.
+ (goto-char (point-min))
+ (while (null (eobp))
+ ;; Don't fill pre blocks.
+ (unless (sx-question-mode--dont-fill-here)
+ (let ((beg (point)))
+ (skip-chars-forward "\r\n[:blank:]")
+ (forward-paragraph)
+ (fill-region beg (point)))))
+ (goto-char (point-max)))))
+
+(defun sx-question-mode--insert-markdown (text)
+ "Return TEXT fontified according to `markdown-mode'."
+ (let ((beg (point)))
+ (insert
+ ;; Font-locking needs to be done in a temp buffer, because it
+ ;; affects the entire buffer even if we narrow.
+ (with-temp-buffer
+ (insert text)
+ (delay-mode-hooks (markdown-mode))
+ (font-lock-mode -1)
+ (when sx-question-mode-bullet-appearance
+ (font-lock-add-keywords ;; Bullet items.
+ nil
+ `((,(rx line-start (0+ blank) (group-n 1 (any "*+-")) blank)
+ 1 '(face nil display ,sx-question-mode-bullet-appearance) prepend))))
+ (font-lock-add-keywords ;; Highlight usernames.
+ nil
+ `((,(rx (or blank line-start)
+ (group-n 1 (and "@" (1+ (not space))))
+ symbol-end)
+ 1 font-lock-builtin-face)))
+ ;; Everything.
+ (font-lock-fontify-region (point-min) (point-max))
+ (replace-regexp-in-string "[[:blank:]]+\\'" "" (buffer-string))))
+ ;; This part can and should be done in place, this way it can
+ ;; create overlays.
+ (sx-question-mode--process-markdown-in-region beg (point))))
+
+
+;;; HTML tags
+(defconst sx-question-mode--html-tag-regexp
+ (rx "<" (group-n 1 "%s") (* (not (any ">"))) ">"))
+
+(defun sx-question-mode--process-html-tags (beg end)
+ "Hide all html tags between BEG and END and possibly interpret them.
+END should be a marker."
+ ;; This code understands nested html, but not if the same tag is
+ ;; nested in itself (e.g., <kbd><kbd></kbd></kbd>).
+ (goto-char beg)
+ (while (search-forward-regexp
+ (format sx-question-mode--html-tag-regexp "[[:alpha:]]+")
+ end 'noerror)
+ (unless (save-match-data (markdown-code-at-point-p))
+ (let ((tag (match-string 1))
+ (l (match-beginning 0)))
+ (replace-match "")
+ (when (search-forward-regexp
+ (format sx-question-mode--html-tag-regexp (concat "/" tag))
+ ;; Searching for a match has no bounds.
+ nil 'noerror)
+ (let ((r (copy-marker (match-beginning 0))))
+ ;; The code tag is special, because it quotes everything inside.
+ (if (string= tag "code")
+ (progn (replace-match "`")
+ (save-excursion (goto-char l) (insert "`")))
+ (replace-match "")
+ ;; Handle stuff between the two tags.
+ (save-match-data (sx-question-mode--process-html-tags l r))
+ (cond
+ ((string= tag "kbd")
+ (add-text-properties l r '(face markdown-inline-code-face)))
+ ((string= tag "sub")
+ (add-text-properties
+ l r '(face sx-question-mode-sub-sup display (raise -0.3))))
+ ((string= tag "sup")
+ (add-text-properties
+ l r '(face sx-question-mode-sub-sup display (raise +0.3))))))))))))
;;; Handling links
(defun sx-question-mode--process-links-in-buffer ()
- "Turn all markdown links in this buffer into compact format."
+ "Turn all markdown links between BEG and ENG into compact format.
+END must be a marker.
+Image links are downloaded and displayed, if
+`sx-question-mode-use-images' is non-nil."
(save-excursion
(goto-char (point-min))
(while (search-forward-regexp sx-question-mode--link-regexp nil t)
- (let* ((text (match-string-no-properties 1))
- (url (or (match-string-no-properties 2)
- (match-string-no-properties 4)
- (sx-question-mode-find-reference
- (match-string-no-properties 3)
- text)))
- (full-text (match-string-no-properties 0)))
- (when (stringp url)
- (replace-match "")
- (sx-question-mode--insert-link
- (or (if sx-question-mode-pretty-links text full-text) url)
- url))))))
+ ;; Tags are tag-buttons.
+ (let ((tag (match-string-no-properties 5)))
+ (if (and tag (> (length tag) 0))
+ (progn (replace-match "")
+ (sx-tag--insert tag))
+ ;; Other links are link-buttons.
+ (let* ((text (match-string-no-properties 1))
+ (url (or (match-string-no-properties 2)
+ (match-string-no-properties 4)
+ (sx-question-mode-find-reference
+ (match-string-no-properties 3)
+ text)))
+ (full-text (match-string-no-properties 0))
+ (image-p (and sx-question-mode-use-images
+ (eq ?! (elt full-text 0)))))
+ (when (stringp url)
+ (replace-match "")
+ (sx-question-mode--insert-link
+ (cond (image-p nil)
+ ((and sx-question-mode-pretty-links text))
+ ((not text) (sx--shorten-url url))
+ (t full-text))
+ url)
+ (when image-p
+ (sx-question-mode--create-image url (- (point) 2))))))))))
+
+(defun sx-question-mode--create-image (url point)
+ "Get and create an image from URL and insert it at POINT.
+The image will take the place of the character at POINT.
+Its size is bound by `sx-question-mode-image-max-width' and
+`window-body-width'."
+ (let* ((ov (make-overlay point (1+ point) (current-buffer) t nil))
+ (callback
+ (lambda (data)
+ (let* ((image (create-image data 'imagemagick t))
+ (image-width (car (image-size image 'pixels))))
+ (overlay-put
+ ov 'display
+ (append image
+ (list :width (min sx-question-mode-image-max-width
+ (window-body-width nil 'pixel)
+ image-width))))))))
+ (sx-request-get-url url callback)
+ (overlay-put ov 'face 'default)))
(defun sx-question-mode--insert-link (text url)
- "Return a link propertized version of string TEXT.
+ "Return a link propertized version of TEXT-OR-IMAGE.
URL is used as 'help-echo and 'url properties."
- (insert-text-button
- text
- ;; Mouse-over
- 'help-echo
- (format sx-button--link-help-echo
- (propertize (sx--shorten-url url)
- 'face 'font-lock-function-name-face))
- ;; For visiting and stuff.
- 'sx-button-url url
- 'sx-button-copy url
- :type 'sx-button-link))
+ ;; For now, the only way to handle nested links is to remove them.
+ (when (eq (char-before) ?\[)
+ (insert "a")
+ (forward-char -2)
+ (if (looking-at sx-question-mode--link-regexp)
+ (replace-match "")
+ (forward-char 1)
+ (delete-char 1)))
+ ;; Images need to be at the start of a line.
+ (unless (or text (looking-at-p "^"))
+ (insert "\n"))
+ (insert-text-button (or text " ")
+ ;; Mouse-over
+ 'help-echo
+ (format sx-button--link-help-echo
+ ;; If TEXT is a shortened url, we don't shorten URL.
+ (propertize (if (string-match "^https?:" (or text ""))
+ url (sx--shorten-url url))
+ 'face 'font-lock-function-name-face))
+ ;; For visiting and stuff.
+ 'sx-button-url url
+ 'sx-button-copy url
+ :type 'sx-button-link)
+ ;; Images need to be at the end of a line too.
+ (unless text (insert "\n")))
(defun sx-question-mode-find-reference (id &optional fallback-id)
"Find url identified by reference ID in current buffer.
diff --git a/sx-question.el b/sx-question.el
index 1fde1aa..1162eb9 100644
--- a/sx-question.el
+++ b/sx-question.el
@@ -197,20 +197,14 @@ If no cache exists for it, initialize one with SITE."
;;;; Other data
-
(defun sx-question--accepted-answer-id (question)
"Return accepted answer in QUESTION or nil if none exists."
(sx-assoc-let question
(and (integerp .accepted_answer_id)
.accepted_answer_id)))
-(defun sx-question--tag-format (tag)
- "Formats TAG for display."
- (concat "[" tag "]"))
-
;;; Question Mode Answer-Sorting Functions
-
(sx--create-comparator sx-answer-higher-score-p
"Return t if answer A has a higher score than answer B."
#'> (lambda (x) (cdr (assq 'score x))))
diff --git a/sx-request.el b/sx-request.el
index 8f672ec..3bcea21 100644
--- a/sx-request.el
+++ b/sx-request.el
@@ -221,28 +221,52 @@ Currently returns nil."
"https://raw.githubusercontent.com/vermiculus/sx.el/data/data/%s.el"
"Url of the \"data\" directory inside the SX `data' branch.")
-(defun sx-request-get-data (file)
- "Fetch and return data stored online by SX.
-FILE is a string or symbol, the name of the file which holds the
-desired data, relative to `sx-request--data-url-format'. For
-instance, `tags/emacs' returns the list of tags on Emacs.SE."
+(defun sx-request--read-buffer-data ()
+ "Return the buffer contents after any url headers.
+Error if url headers are absent or if they indicate something
+went wrong."
+ (goto-char (point-min))
+ (unless (string-match "200" (thing-at-point 'line))
+ (error "Page not found."))
+ (if (not (search-forward "\n\n" nil t))
+ (error "Headers missing; response corrupt")
+ (prog1 (buffer-substring (point) (point-max))
+ (kill-buffer (current-buffer)))))
+
+(defun sx-request-get-url (url &optional callback)
+ "Fetch and return data stored online at URL.
+If CALLBACK is nil, fetching is done synchronously and the
+data (buffer contents sans headers) is returned as a string.
+
+Otherwise CALLBACK must be a function of a single argument. Then
+`url-retrieve' is called asynchronously and CALLBACK is passed
+the retrieved data."
(let* ((url-automatic-caching t)
(url-inhibit-uncompression t)
- (request-url (format sx-request--data-url-format file))
(url-request-method "GET")
(url-request-extra-headers
'(("Content-Type" . "application/x-www-form-urlencoded")))
- (response-buffer (url-retrieve-synchronously request-url)))
- (if (not response-buffer)
- (error "Something went wrong in `url-retrieve-synchronously'")
- (with-current-buffer response-buffer
- (progn
- (goto-char (point-min))
- (if (not (search-forward "\n\n" nil t))
- (error "Headers missing; response corrupt")
- (when (looking-at-p "Not Found") (error "Page not found."))
- (prog1 (read (current-buffer))
- (kill-buffer (current-buffer)))))))))
+ (callback-internal
+ (when callback
+ ;; @TODO: Error check in STATUS.
+ (lambda (_status)
+ (funcall callback (sx-request--read-buffer-data)))))
+ (response-buffer
+ (if callback (url-retrieve url callback-internal nil 'silent)
+ (url-retrieve-synchronously url))))
+ (unless callback
+ (if (not response-buffer)
+ (error "Something went wrong in `url-retrieve-synchronously'")
+ (with-current-buffer response-buffer
+ (sx-request--read-buffer-data))))))
+
+(defun sx-request-get-data (file)
+ "Fetch and return data stored online by SX.
+FILE is a string or symbol, the name of the file which holds the
+desired data, relative to `sx-request--data-url-format'. For
+instance, `tags/emacs' returns the list of tags on Emacs.SE."
+ (read (sx-request-get-url
+ (format sx-request--data-url-format file))))
;;; Support Functions
diff --git a/sx-search.el b/sx-search.el
index 4b0a0b2..d0fa892 100644
--- a/sx-search.el
+++ b/sx-search.el
@@ -32,6 +32,7 @@
(require 'sx)
(require 'sx-question-list)
+(require 'sx-question-mode)
(require 'sx-tag)
(defvar sx-search--query-history nil
@@ -123,6 +124,25 @@ prefix argument, the user is asked for everything."
(sx-question-list-refresh 'redisplay)
(switch-to-buffer (current-buffer))))
+
+;;; Tag
+(defun sx-search-tag-at-point (&optional pos)
+ "Follow tag under position POS or point."
+ (interactive)
+ (let ((tag (save-excursion
+ (when pos (goto-char pos))
+ (or (get-text-property (point) 'sx-tag)
+ (thing-at-point 'symbol))))
+ (meta (save-excursion
+ (when pos (goto-char pos))
+ (get-text-property (point) 'sx-tag-meta)))
+ (site (replace-regexp-in-string
+ (rx string-start "meta.") ""
+ (or sx-question-list--site
+ (sx-assoc-let sx-question-mode--data .site_par)))))
+ (sx-search (concat (when meta "meta.") site)
+ nil tag)))
+
(provide 'sx-search)
;;; sx-search.el ends here
diff --git a/sx-tag.el b/sx-tag.el
index b2ad375..3c00ae2 100644
--- a/sx-tag.el
+++ b/sx-tag.el
@@ -23,6 +23,13 @@
(require 'sx)
(require 'sx-method)
+(require 'sx-button)
+
+(defface sx-tag
+ '((t :underline nil :inherit font-lock-function-name-face))
+ "Face used on the question tags in the question buffer."
+ :group 'sx-question-mode-faces
+ :group 'sx-question-list-faces)
;;; Getting the list from a site
@@ -133,6 +140,37 @@ tags."
(push input list))
(reverse list)))
+
+;;; Printing
+(defun sx-tag--format (tag &optional meta)
+ "Format and return TAG for display.
+If META is non-nil, the tag is for the meta site."
+ (with-temp-buffer
+ (sx-tag--insert tag meta)
+ (buffer-string)))
+
+(defun sx-tag--insert (tag &optional meta)
+ "Insert TAG button.
+If META is non-nil, the tag is for the meta site."
+ (insert-text-button (concat "[" tag "]")
+ 'sx-button-copy tag
+ 'sx-tag tag
+ 'sx-tag-meta meta
+ :type 'sx-button-tag))
+
+(defun sx-tag--format-tags (tags &optional site)
+ "Format and concatenate a sequence of TAGS.
+Returns a string of all tags in TAGS, separated by a space.
+
+SITE is the site to which the tags refer, it is only used to
+decide whether they are main or meta tags. SITE can also be t or
+nil, which respectively indicate meta and main."
+ (let ((is-meta
+ (if (stringp site) (string-match (rx string-start "meta.") site)
+ site)))
+ (mapconcat (lambda (tag) (sx-tag--format tag is-meta))
+ tags " ")))
+
(provide 'sx-tag)
;;; sx-tag.el ends here
diff --git a/sx.el b/sx.el
index 33b36b6..194e32f 100644
--- a/sx.el
+++ b/sx.el
@@ -187,8 +187,19 @@ If ALIST doesn't have a `site' property, one is created using the
,(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'."
@@ -204,7 +215,7 @@ is intentionally skipped."
(while (and ;; We're not at the end.
(cdr-safe tail)
;; We're not at the right place.
- (,(or predicate #'<) x (cadr tail)))
+ (funcall (or ,predicate #'<) x (cadr tail)))
(setq tail (cdr tail)))
(setcdr tail (cons x (cdr tail)))))
@@ -335,6 +346,16 @@ GET-FUNC and performs the actual comparison."
"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
@@ -419,6 +440,39 @@ if ALIST contains a different string at the ?% entry."
(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'."
diff --git a/test/test-api.el b/test/test-api.el
index b7d5dbb..faf2e0a 100644
--- a/test/test-api.el
+++ b/test/test-api.el
@@ -14,3 +14,26 @@
(ert-deftest test-method-get-all ()
"Tests sx-method interface to `sx-request-all-items'"
(should (< 250 (length (sx-method-call 'sites :get-all t)))))
+
+(ert-deftest request-get-url ()
+ (should (sx-request-get-url "http://google.com"))
+ (should-error (sx-request-get-url "http://github.com/Bruce-Connor/does-not-exist"))
+ (when sx-question-mode-use-images
+ (should
+ ;; If image is not recognized, this returns nil.
+ (create-image (sx-request-get-url "https://raw.githubusercontent.com/vermiculus/sx.el/master/list-and-question.png")
+ 'imagemagick t
+ :width sx-question-mode-image-max-width)))
+ ;; In case imagemacgick is not available, let's try png so we at
+ ;; least test the function.
+ (when (image-type-available-p 'png)
+ (should
+ (create-image (sx-request-get-url "https://raw.githubusercontent.com/vermiculus/sx.el/master/list-and-question.png")
+ 'png t
+ :width sx-question-mode-image-max-width))))
+
+(ert-deftest request-get-data ()
+ (should-error (sx-request-get-data "tags/emacs-does-not-exist"))
+ (let ((emacs-tags (sx-request-get-data 'tags/emacs)))
+ (should (> (length emacs-tags) 450))
+ (should (not (cl-remove-if #'stringp emacs-tags)))))
diff --git a/test/test-printing.el b/test/test-printing.el
index 6fa77b9..4c72f68 100644
--- a/test/test-printing.el
+++ b/test/test-printing.el
@@ -13,7 +13,7 @@
(defmacro question-list-regex (title votes answers &rest tags)
"Construct a matching regexp for TITLE, VOTES, and ANSWERS.
Each element of TAGS is appended at the end of the expression
-after being run through `sx-question--tag-format'."
+after being run through `sx-tag--format'."
`(rx line-start
(+ whitespace) ,(number-to-string votes)
(+ whitespace) ,(number-to-string answers)
@@ -22,8 +22,7 @@ after being run through `sx-question--tag-format'."
(+ (any whitespace digit))
(or "y" "d" "h" "m" "mo" "s") " ago"
(+ whitespace)
- (eval (mapconcat #'sx-question--tag-format
- (list ,@tags) " "))))
+ (eval (mapconcat #'sx-tag--format (list ,@tags) " "))))
;;; Tests
@@ -40,11 +39,18 @@ after being run through `sx-question--tag-format'."
(sx-time-since 1420105000.)))))
(ert-deftest question-list-tag ()
- "Test `sx-question--tag-format'."
+ "Test `sx-tag--format'."
(should
- (string=
- (sx-question--tag-format "tag")
- "[tag]")))
+ (string= (sx-tag--format "tag") "[tag]"))
+ (with-temp-buffer
+ (insert (sx-tag--format "tag"))
+ (should (get-char-property (point-min) 'button))
+ (should
+ (eq (get-char-property (point-min) 'face) 'sx-tag))
+ (should
+ (string= (get-char-property (point-min) 'sx-tag) "tag"))
+ (should
+ (string= (get-char-property (point-min) 'sx-button-copy) "tag"))))
(ert-deftest question-list-display ()
(cl-letf (((symbol-function #'sx-request-make)
@@ -162,8 +168,9 @@ after being run through `sx-question--tag-format'."
"Check complicated questions are filled correctly."
(should
(equal
- (sx-question-mode--fill-and-fontify
- "Creating an account on a new site requires you to log into that site using *the same credentials you used on existing sites.* For instance, if you used the Stack Exchange login method, you'd...
+ (with-temp-buffer
+ (sx-question-mode--insert-markdown
+ "Creating an account on a new site requires you to log into that site using *the same credentials you used on existing sites.* For instance, if you used the Stack Exchange login method, you'd...
1. Click the \"Log in using Stack Exchange\" button:
@@ -187,6 +194,7 @@ after being run through `sx-question--tag-format'."
[1]: http://i.stack.imgur.com/ktFTs.png
[2]: http://i.stack.imgur.com/5l2AY.png
[3]: http://i.stack.imgur.com/22myl.png")
+ (buffer-string))
"Creating an account on a new site requires you to log into that site
using *the same credentials you used on existing sites.* For instance,
if you used the Stack Exchange login method, you'd...