Merge branch 'delete-command' into json-false

6 files changed, 192 insertions, 130 deletions

diff --git a/sx-interaction.el b/sx-interaction.el
index 3d60cbe..368da09 100644
--- a/sx-interaction.el
+++ b/sx-interaction.el
@@ -230,14 +230,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 +261,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 +270,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.
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 32bc140..4f298a3 100644
--- a/sx-question-list.el
+++ b/sx-question-list.el
@@ -210,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.")
 
 (defconst sx-question-list--order-methods
@@ -332,34 +352,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)
 
 (defun sx-question-list-hide (data)
   "Hide question under point.
diff --git a/sx-question-mode.el b/sx-question-mode.el
index 53007a1..561ae23 100644
--- a/sx-question-mode.el
+++ b/sx-question-mode.el
@@ -163,28 +163,42 @@ 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
@@ -237,33 +251,10 @@ on the current buffer use
   (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)
-   ("O" sx-question-mode-order-by)
-   ("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.
diff --git a/sx-question-print.el b/sx-question-print.el
index 8d61773..454285d 100644
--- a/sx-question-print.el
+++ b/sx-question-print.el
@@ -204,6 +204,8 @@ type is not available, images won't work."
 (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)
@@ -212,7 +214,9 @@ QUESTION must be a data structure returned by `json-read'."
   (sx-question-mode--print-section question)
   (sx-assoc-let 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
@@ -223,9 +227,9 @@ QUESTION must be a data structure returned by `json-read'."
   "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
@@ -288,29 +292,32 @@ DATA can represent a question or an answer."
           (insert "\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"
diff --git a/sx.el b/sx.el
index e5e9c3e..194e32f 100644
--- a/sx.el
+++ b/sx.el
@@ -346,6 +346,10 @@ 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 #'>.
@@ -436,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'."