Merge pull request #93 from vermiculus/voting

Voting

6 files changed, 249 insertions, 97 deletions

diff --git a/sx-auth.el b/sx-auth.el
index 217da7d..2217b8b 100644
--- a/sx-auth.el
+++ b/sx-auth.el
@@ -72,7 +72,10 @@ If all SUBMETHODS require auth or there are no submethods, form
 will be (METHOD  . t)")
 
 (defvar sx-auth-filter-auth '(question.upvoted
-                              question.downvoted)
+                              question.downvoted
+                              answer.upvoted
+                              answer.downvoted
+                              comment.upvoted)
   "List of filter types that require auth.
 Keywords are of form (OBJECT TYPES) where TYPES is (FILTER FILTER
 FILTER).")
diff --git a/sx-interaction.el b/sx-interaction.el
new file mode 100644
index 0000000..a9203bd
--- /dev/null
+++ b/sx-interaction.el
@@ -0,0 +1,110 @@
+;;; sx-interaction.el --- Voting, commenting, and otherwise interacting with questions.  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2014  Artur Malabarba
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(require 'sx)
+(require 'sx-question)
+(require 'sx-question-mode)
+(require 'sx-question-list)
+
+
+;;; Using data in buffer
+(defun sx--data-here ()
+  "Get the text property `sx--data-here'."
+  (or (get-text-property (point) 'sx--data-here)
+      (and (derived-mode-p 'sx-question-list-mode)
+           (tabulated-list-get-id))
+      (or (derived-mode-p 'sx-question-mode)
+          sx-question-mode--data)))
+
+(defun sx--maybe-update-display ()
+  "Refresh the question list if we're inside it."
+  (cond
+   ((derived-mode-p 'sx-question-list-mode)
+    (sx-question-list-refresh 'redisplay 'no-update))
+   ((derived-mode-p 'sx-question-mode)
+    (sx-question-mode-refresh 'no-update))))
+
+(defun sx--copy-data (from to)
+  "Copy all fields of alist FORM onto TO.
+Only fields contained in TO are copied."
+  (setcar to (car from))
+  (setcdr to (cdr from)))
+
+(defun sx-visit (data)
+  "Visit DATA in a web browser.
+DATA can be a question, answer, or comment. Interactively, it is
+derived from point position.
+If DATA is a question, also mark it as read."
+  (interactive (list (sx--data-here)))
+  (sx-assoc-let data
+    (when (stringp .link)
+      (browse-url .link))
+    (when .title
+      (sx-question--mark-read data)
+      (sx--maybe-update-display))))
+
+(defun sx-toggle-upvote (data)
+  "Apply or remove upvote from DATA.
+DATA can be a question, answer, or comment. Interactively, it is
+guessed from context at point."
+  (interactive (list (sx--data-here)))
+  (sx-assoc-let data
+    (sx-set-vote data "upvote" (null (eq .upvoted t)))))
+
+(defun sx-toggle-downvote (data)
+  "Apply or remove downvote from DATA.
+DATA can be a question or an answer. Interactively, it is guessed
+from context at point."
+  (interactive (list (sx--data-here)))
+  (sx-assoc-let data
+    (sx-set-vote data "downvote" (null (eq .downvoted t)))))
+
+(defun sx-set-vote (data type status)
+  "Set the DATA's vote TYPE to STATUS.
+DATA can be a question, answer, or comment. TYPE can be
+\"upvote\" or \"downvote\". STATUS is a boolean.
+
+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))))
+    ;; The api returns the new DATA.
+    (when (> (length result) 0)
+      (sx--copy-data (elt result 0) data)
+      ;; Display the changes in `data'.
+      (sx--maybe-update-display))))
+
+(provide 'sx-interaction)
+;;; sx-interaction.el ends here
diff --git a/sx-question-list.el b/sx-question-list.el
index ce6c1d6..4d7681b 100644
--- a/sx-question-list.el
+++ b/sx-question-list.el
@@ -288,6 +288,8 @@ into consideration.
    ("g" sx-question-list-refresh)
    (":" sx-question-list-switch-site)
    ("v" sx-visit)
+   ("u" sx-toggle-upvote)
+   ("d" sx-toggle-downvote)
    ("h" sx-question-list-hide)
    ("m" sx-question-list-mark-read)
    ([?\r] sx-question-list-display-question)))
diff --git a/sx-question-mode.el b/sx-question-mode.el
index 59313d1..f1a8cc0 100644
--- a/sx-question-mode.el
+++ b/sx-question-mode.el
@@ -54,13 +54,17 @@
 If WINDOW is nil, use selected one.
 
 Returns the question buffer."
+  (with-current-buffer
+      (sx-question-mode--display-buffer window)
+    (sx-question-mode--erase-and-print-question data)))
+
+(defun sx-question-mode--erase-and-print-question (data)
+  "Erase contents of buffer and print question given by DATA."
   (let ((inhibit-read-only t))
-    (with-current-buffer
-        (sx-question-mode--display-buffer window)
-      (erase-buffer)
-      (sx-question-mode)
-      (sx-question-mode--print-question data)
-      (current-buffer))))
+    (erase-buffer)
+    (sx-question-mode)
+    (sx-question-mode--print-question data)
+    (current-buffer)))
 
 (defun sx-question-mode--display-buffer (window)
   "Display and return the buffer used for displaying a question.
@@ -134,11 +138,32 @@ If WINDOW is given, use that to display the buffer."
   "Face used for author names in the question buffer."
   :group 'sx-question-mode-faces)
 
+(defface sx-question-mode-score
+  '((t))
+  "Face used for the score in the question buffer."
+  :group 'sx-question-mode-faces)
+
+(defface sx-question-mode-score-downvoted
+  '((t :inherit (font-lock-warning-face sx-question-mode-score)))
+  "Face used for downvoted score in the question buffer."
+  :group 'sx-question-mode-faces)
+
+(defface sx-question-mode-score-upvoted
+  '((t :weight bold
+       :inherit (font-lock-function-name-face sx-question-mode-score)))
+  "Face used for downvoted score in the question buffer."
+  :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:    "
+  "String used before the question score at the header."
+  :type 'string
+  :group 'sx-question-mode)
+
 (defface sx-question-mode-content-face
   '((((background dark)) :background "#090909")
     (((background light)) :background "#f4f4f4"))
@@ -195,10 +220,9 @@ QUESTION must be a data structure returned by `json-read'."
   ;; Print everything
   (sx-question-mode--print-section question)
   (sx-assoc-let question
-                (mapc #'sx-question-mode--print-section .answers))
+    (mapc #'sx-question-mode--print-section .answers))
   (goto-char (point-min))
-  (with-selected-window sx-question-mode--window
-    (sx-question-mode-next-section)))
+  (sx-question-mode-next-section))
 
 (defvar sx-question-mode--section-help-echo
   (format
@@ -249,6 +273,13 @@ DATA can represent a question or an answer."
                     (sx-time-since .last_edit_date)
                     (sx-question-mode--propertize-display-name .last_editor))))
          'sx-question-mode-date)
+        (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)))
         (when .title
           ;; Tags
           (sx-question-mode--insert-header
@@ -332,7 +363,6 @@ where `value' is given `face' as its face.
 (defun sx-question-mode--fill-and-fontify (text)
   "Return TEXT filled according to `markdown-mode'."
   (with-temp-buffer
-    (erase-buffer)
     (insert text)
     (markdown-mode)
     (font-lock-mode -1)
@@ -344,8 +374,8 @@ where `value' is given `face' as its face.
     (font-lock-add-keywords ;; Highlight usernames.
      nil
      `((,(rx (or blank line-start)
-            (group-n 1 (and "@" (1+ (or (syntax word) (syntax symbol)))))
-            symbol-end)
+             (group-n 1 (and "@" (1+ (or (syntax word) (syntax symbol)))))
+             symbol-end)
         1 font-lock-builtin-face)))
     ;; Everything.
     (font-lock-fontify-region (point-min) (point-max))
@@ -542,6 +572,8 @@ Letters do not insert themselves; instead, they are commands.
    ("p" sx-question-mode-previous-section)
    ("g" sx-question-mode-refresh)
    ("v" sx-visit)
+   ("u" sx-toggle-upvote)
+   ("d" sx-toggle-downvote)
    ("q" quit-window)
    (" " scroll-up-command)
    (,(kbd "S-SPC") scroll-down-command)
@@ -552,16 +584,24 @@ Letters do not insert themselves; instead, they are commands.
    (,(kbd "<backtab>") backward-button)
    ([return] push-button)))
 
-(defun sx-question-mode-refresh ()
+(defun sx-question-mode-refresh (&optional no-update)
   "Refresh currently displayed question.
 Queries the API for any changes to the question or its answers or
-comments, and redisplays it."
-  (interactive)
+comments, and redisplays it.
+
+With non-nil prefix argument NO-UPDATE, just redisplay, don't
+query the api."
+  (interactive "P")
   (sx-question-mode--ensure-mode)
-  (sx-assoc-let sx-question-mode--data
-    (sx-question-mode--display
-     (sx-question-get-question .site .question_id)
-     (selected-window))))
+  (let ((point (point)))
+    (sx-question-mode--erase-and-print-question
+     (if no-update
+         sx-question-mode--data
+       (sx-assoc-let sx-question-mode--data
+         (sx-question-get-question .site .question_id))))
+    (goto-char point)
+    (when (get-buffer-window (current-buffer))
+      (recenter))))
 
 (defun sx-question-mode--ensure-mode ()
   "Ensures we are in question mode, erroring otherwise."
diff --git a/sx-question.el b/sx-question.el
index 06e8648..de07c94 100644
--- a/sx-question.el
+++ b/sx-question.el
@@ -26,43 +26,18 @@
 (require 'sx-filter)
 (require 'sx-method)
 
-(defvar sx-question-browse-filter
-  '((question.body_markdown
-     question.comments
-     question.answers
-     question.last_editor
-     question.accepted_answer_id
-     question.link
-     question.upvoted
-     question.downvoted
-     user.display_name
-     comment.owner
-     comment.body_markdown
-     comment.body
-     comment.link
-     answer.last_editor
-     answer.link
-     answer.owner
-     answer.body_markdown
-     answer.comments)
-    (user.profile_image shallow_user.profile_image))
-  "The filter applied when retrieving question data.
-See `sx-question-get-questions' and `sx-question-get-question'.")
-
 (defun sx-question-get-questions (site &optional page)
   "Get SITE questions.  Return page PAGE (the first if nil).
 Return a list of question.  Each question is an alist of
 properties returned by the API with an added (site SITE)
 property.
 
-`sx-method-call' is used with `sx-question-browse-filter'."
-  (mapcar
-   (lambda (question) (cons (cons 'site site) question))
-   (sx-method-call 'questions
-     :keywords `((page . ,page))
-     :site site
-     :auth t
-     :filter sx-question-browse-filter)))
+`sx-method-call' is used with `sx-browse-filter'."
+  (sx-method-call 'questions
+    :keywords `((page . ,page))
+    :site site
+    :auth t
+    :filter sx-browse-filter))
 
 (defun sx-question-get-question (site question-id)
   "Query SITE for a QUESTION-ID and return it.
@@ -71,7 +46,7 @@ If QUESTION-ID doesn't exist on SITE, raise an error."
                :id id
                :site site
                :auth t
-               :filter sx-question-browse-filter)))
+               :filter sx-browse-filter)))
     (if (vectorp res)
         (elt res 0)
       (error "Couldn't find question %S in %S"
@@ -159,23 +134,20 @@ If no cache exists for it, initialize one with SITE."
 
 (defun sx-question--mark-hidden (question)
   "Mark QUESTION as being hidden."
-  (sx-assoc-let question
-    (sx-question--ensure-hidden-list .site)
-    (let ((site-cell (assoc .site sx-question--user-hidden-list))
-          cell)
-      ;; If question already hidden, do nothing.
-      (unless (memq .question_id site-cell)
-        ;; First question from this site.
-        (if (null site-cell)
-            (push (list .site .question_id) sx-question--user-hidden-list)
-          ;; Question wasn't present.
-          ;; Add it in, but make sure it's sorted (just in case we need
-          ;; it later).
-          (sx-sorted-insert-skip-first .question_id site-cell >))
-        ;; This causes a small lag on `j' and `k' as the list gets large.
-        ;; Should we do this on a timer?
-        ;; Save the results.
-        (sx-cache-set 'hidden-questions sx-question--user-hidden-list)))))
+  (let ((site-cell (assoc .site sx-question--user-hidden-list))
+        cell)
+    ;; If question already hidden, do nothing.
+    (unless (memq .question_id site-cell)
+      ;; First question from this site.
+      (push (list .site .question_id) sx-question--user-hidden-list)
+      ;; Question wasn't present.
+      ;; Add it in, but make sure it's sorted (just in case we need
+      ;; it later).
+      (sx-sorted-insert-skip-first .question_id site-cell >)
+      ;; This causes a small lag on `j' and `k' as the list gets large.
+      ;; Should we do this on a timer?
+      ;; Save the results.
+      (sx-cache-set 'hidden-questions sx-question--user-hidden-list))))
 
 
 ;;;; Other data
diff --git a/sx.el b/sx.el
index 0bab861..e5f81a4 100644
--- a/sx.el
+++ b/sx.el
@@ -46,6 +46,37 @@
   (browse-url "https://github.com/vermiculus/stack-mode/issues/new"))
 
 
+;;; Browsing filter
+(defvar sx-browse-filter
+  '((question.body_markdown
+     question.comments
+     question.answers
+     question.last_editor
+     question.accepted_answer_id
+     question.link
+     question.upvoted
+     question.downvoted
+     user.display_name
+     comment.owner
+     comment.body_markdown
+     comment.body
+     comment.link
+     comment.edited
+     comment.creation_date
+     comment.upvoted
+     comment.score
+     answer.last_editor
+     answer.link
+     answer.owner
+     answer.body_markdown
+     answer.upvoted
+     answer.downvoted
+     answer.comments)
+    (user.profile_image shallow_user.profile_image))
+  "The filter applied when retrieving question data.
+See `sx-question-get-questions' and `sx-question-get-question'.")
+
+
 ;;; Utility Functions
 
 (defmacro sx-sorted-insert-skip-first (newelt list &optional predicate)
@@ -162,30 +193,20 @@ Return the result of BODY."
      (add-text-properties p (point) ,properties)
      result))
 
-
-;;; Using data in buffer
-(defun sx--data-here ()
-  "Get the text property `sx--data-here'."
-  (or (get-text-property (point) 'sx--data-here)
-      (and (derived-mode-p 'sx-question-list-mode)
-           (tabulated-list-get-id))))
-
-(defun sx-visit (data)
-  "Visit DATA in a web browser.
-DATA can be a question, answer, or comment. Interactively, it is
-derived from point position.
-If DATA is a question, also mark it as read."
-  (interactive (list (sx--data-here)))
-  (sx-assoc-let data
-    (when (stringp .link)
-      (browse-url .link))
-    (when (and .title (fboundp 'sx-question--mark-read))
-      (sx-question--mark-read data)
-      (when ((derived-mode-p 'sx-question-list-mode))
-        (sx-question-list-refresh 'redisplay 'no-update)))))
-
-
 ;;; Assoc-let
+(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)))))
+    (unless (stringp link)
+      (error "Data has no link property"))
+    (replace-regexp-in-string
+     "^https?://\\(?:\\(?1:[^/]+\\)\\.stackexchange\\|\\(?2:[^/]+\\)\\)\\.[^.]+/.*$"
+     "\\1\\2" link)))
+
 (defun sx--deep-dot-search (data)
   "Find symbols somewhere inside DATA which start with a `.'.
 Returns a list where each element is a cons cell.  The car is the
@@ -206,6 +227,8 @@ symbol, the cdr is the symbol without the `.'."
   "Use dotted symbols let-bound to their values in ALIST and execute BODY.
 Dotted symbol is any symbol starting with a `.'.  Only those
 present in BODY are letbound, which leads to optimal performance.
+The .site symbol is special, it is derived from the .link symbol
+using `sx--site'.
 
 For instance, the following code
 
@@ -217,11 +240,13 @@ is equivalent to
   (let ((.title (cdr (assoc 'title alist)))
         (.body (cdr (assoc 'body alist))))
     (list .title .body))"
-  (declare (indent 1)
-           (debug t))
-  (let ((symbol-alist (sx--deep-dot-search body)))
-    `(let ,(mapcar (lambda (x) `(,(car x) (cdr (assoc ',(cdr x) ,alist))))
-                   (delete-dups symbol-alist))
+  (declare (indent 1) (debug t))
+  (let* ((symbol-alist (sx--deep-dot-search body))
+         (has-site (assoc '.site symbol-alist)))
+    `(let ,(append
+            (when has-site `((.site (sx--site (cdr (assoc 'link ,alist))))))
+            (mapcar (lambda (x) `(,(car x) (cdr (assoc ',(cdr x) ,alist))))
+                    (remove '(.site . site) (delete-dups symbol-alist))))
        ,@body)))
 
 (defcustom sx-init-hook nil