Merge pull request #233 from vermiculus/tag-buttons

Tag buttons

7 files changed, 90 insertions, 41 deletions

diff --git a/sx-button.el b/sx-button.el
index 992c654..8a4bcc0 100644
--- a/sx-button.el
+++ b/sx-button.el
@@ -122,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"
@@ -163,6 +169,13 @@ usually part of a code-block."
   'face      'sx-user-name
   :supertype 'sx-button)
 
+(declare-function sx-search-tag-at-point "sx-tag")
+(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-question-list.el b/sx-question-list.el
index 7757503..333fd83 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" (mapconcat #'sx-tag--format .tags " "))
          " "
          (sx-user--format "%15d %4r" .owner)
          (propertize " " 'display "\n")))))))
diff --git a/sx-question-print.el b/sx-question-print.el
index 778b580..190c924 100644
--- a/sx-question-print.el
+++ b/sx-question-print.el
@@ -79,11 +79,6 @@ Some faces of this mode might be defined in the `sx-user' group."
   :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."
@@ -228,8 +223,8 @@ DATA can represent a question or an answer."
           ;; Tags
           (sx-question-mode--insert-header
            sx-question-mode-header-tags
-           (mapconcat #'sx-question--tag-format .tags " ")
-           'sx-question-mode-tags))
+           (mapconcat #'sx-tag--format .tags " ")
+           nil))
         ;; Body
         (insert "\n"
                 (propertize sx-question-mode-separator
@@ -304,7 +299,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)
@@ -322,7 +320,8 @@ E.g.:
 
 (defconst sx-question-mode--link-regexp
   ;; Done at compile time.
-  (rx (or (and "[" (group-n 1 (1+ (not (any "]")))) "]"
+  (rx (or (and "[tag:" (group-n 5 (+ (not (any " ]")))) "]")
+          (and "[" (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") "://") ""
@@ -370,18 +369,24 @@ E.g.:
   (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)))
+            (when (stringp url)
+              (replace-match "")
+              (sx-question-mode--insert-link
+               (or (if sx-question-mode-pretty-links text full-text) url)
+               url))))))))
 
 (defun sx-question-mode--insert-link (text url)
   "Return a link propertized version of string TEXT.
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-search.el b/sx-search.el
index 55964b9..b33efff 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
@@ -117,6 +118,19 @@ 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)))))
+    (sx-search (or sx-question-list--site
+                   (sx-assoc-let sx-question-mode--data .site_par))
+               nil tag)))
+
 (provide 'sx-search)
 ;;; sx-search.el ends here
 
diff --git a/sx-tag.el b/sx-tag.el
index b2ad375..316226b 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,21 @@ tags."
       (push input list))
     (reverse list)))
 
+
+;;; Printing
+(defun sx-tag--format (tag)
+  "Format and return TAG for display."
+  (with-temp-buffer
+    (sx-tag--insert tag)
+    (buffer-string)))
+
+(defun sx-tag--insert (tag)
+  "Insert TAG button."
+  (insert-text-button (concat "[" tag "]")
+                      'sx-button-copy tag
+                      'sx-tag tag
+                      :type 'sx-button-tag))
+
 (provide 'sx-tag)
 ;;; sx-tag.el ends here
 
diff --git a/test/test-printing.el b/test/test-printing.el
index bcc3dd9..8016444 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)