diff options
| -rw-r--r-- | sx-babel.el | 2 | ||||
| -rw-r--r-- | sx-button.el | 31 | ||||
| -rw-r--r-- | sx-favorites.el | 6 | ||||
| -rw-r--r-- | sx-filter.el | 20 | ||||
| -rw-r--r-- | sx-inbox.el | 1 | ||||
| -rw-r--r-- | sx-interaction.el | 85 | ||||
| -rw-r--r-- | sx-question-list.el | 21 | ||||
| -rw-r--r-- | sx-question-mode.el | 20 | ||||
| -rw-r--r-- | sx-question-print.el | 53 | ||||
| -rw-r--r-- | sx-question.el | 22 | ||||
| -rw-r--r-- | sx-search.el | 2 | ||||
| -rw-r--r-- | sx-switchto.el | 2 | ||||
| -rw-r--r-- | sx-user.el | 203 | ||||
| -rw-r--r-- | sx.el | 213 | ||||
| -rw-r--r-- | sx.org | 79 | ||||
| -rw-r--r-- | test/test-macros.el | 5 | ||||
| -rw-r--r-- | test/test-printing.el | 67 | ||||
| -rw-r--r-- | test/test-util.el | 26 |
18 files changed, 626 insertions, 232 deletions
diff --git a/sx-babel.el b/sx-babel.el index e115817..7f84fe0 100644 --- a/sx-babel.el +++ b/sx-babel.el @@ -22,7 +22,7 @@ ;; This file contains functions and a variable for font-locking the ;; content of markdown pre blocks according to their language. The ;; main configuration point, for both the user and the developer is -;; the varuable `sx-babel-major-mode-alist', which see. +;; the variable `sx-babel-major-mode-alist', which see. ;;; Code: diff --git a/sx-button.el b/sx-button.el index 4c0666b..5a2f052 100644 --- a/sx-button.el +++ b/sx-button.el @@ -23,7 +23,7 @@ ;; buttons, see: ;; http://www.gnu.org/software/emacs/manual/html_node/elisp/Buttons.html ;; -;; Most interactible parts of the SX buffers are buttons. Wherever you +;; Most interactive parts of the SX buffers are buttons. Wherever you ;; are, you can always cycle through all buttons by hitting `TAB', ;; that should help identify what's a button in each buffer. ;; @@ -34,7 +34,7 @@ ;; ;; Buttons can then be inserted in their respective files using ;; `insert-text-button'. Give it the string, the `:type' you defined, -;; and any aditional properties that can only be determined at +;; and any additional properties that can only be determined at ;; creation. Existing text can be transformed into a button with ;; `make-text-button' instead. @@ -104,23 +104,29 @@ usually part of a code-block." ;;; Help-echo definitions -(defvar sx-button--help-echo +(defconst sx-button--help-echo (concat "mouse-1, RET" (propertize ": %s -- " 'face 'minibuffer-prompt) "w" (propertize ": copy %s" 'face 'minibuffer-prompt)) "Base help-echo on which others can be written.") -(defvar sx-button--question-title-help-echo +(defconst sx-button--user-help-echo (format sx-button--help-echo - (propertize "hide content" 'face 'minibuffer-prompt) - (propertize "link" 'face 'minibuffer-prompt)) + "visit user page" + "link") + "Help echoed in the minibuffer when point is on a user.") + +(defconst sx-button--question-title-help-echo + (format sx-button--help-echo + "hide content" + "link") "Help echoed in the minibuffer when point is on a section.") -(defvar sx-button--link-help-echo +(defconst sx-button--link-help-echo (format sx-button--help-echo - (propertize "visit %s" 'face 'minibuffer-prompt) - (propertize "URL" 'face 'minibuffer-prompt)) + "visit %s" + "URL") "Help echoed in the minibuffer when point is on a section.") @@ -145,6 +151,13 @@ usually part of a code-block." 'action #'sx-button-follow-link :supertype 'sx-button) +(define-button-type 'sx-button-user + 'action #'sx-button-follow-link + 'help-echo sx-button--user-help-echo + ;; We use different faces on different parts of the user button. + 'face 'sx-user-name + :supertype 'sx-button) + (define-button-type 'sx-button-comment 'help-echo (concat "mouse-1, RET" (propertize ": write a comment" diff --git a/sx-favorites.el b/sx-favorites.el index d98b4c2..444df29 100644 --- a/sx-favorites.el +++ b/sx-favorites.el @@ -45,8 +45,10 @@ Added as hook to initialization." (or (setq sx-favorites--user-favorite-list (sx-cache-get 'question-favorites)) (sx-favorites-update))) -;; Append to ensure `sx-network--initialize is run before it. -(add-hook 'sx-init--internal-hook #'sx-favorites--initialize 'append) +;; ;; Append to ensure `sx-network--initialize' is run before it. +;; This is removed for now because it performs a lot of API calls and +;; was never used. +;; (add-hook 'sx-init--internal-hook #'sx-favorites--initialize 'append) (defun sx-favorites--retrieve-favorites (site) "Obtain list of starred QUESTION_IDs for SITE." diff --git a/sx-filter.el b/sx-filter.el index a3f6861..1ccf611 100644 --- a/sx-filter.el +++ b/sx-filter.el @@ -47,7 +47,7 @@ Structure: ;;; Creation (defmacro sx-filter-from-nil (included) - "Creates a filter data structure with INCLUDED fields. + "Create a filter data structure with INCLUDED fields. All wrapper fields are included by default." `(quote ((,@(sx--tree-expand @@ -64,23 +64,21 @@ All wrapper fields are included by default." .page_size .quota_max .quota_remaining - .total) - nil none))) + ) + nil nil))) ;;; @TODO allow BASE to be a precompiled filter name (defun sx-filter-compile (&optional include exclude base) "Compile INCLUDE and EXCLUDE into a filter derived from BASE. -INCLUDE and EXCLUDE must both be lists; BASE should be a string. +INCLUDE and EXCLUDE must both be lists; BASE should be a symbol. Returns the compiled filter as a string." (let ((keyword-arguments `((include . ,(if include (sx--thing-as-string include))) (exclude . ,(if exclude (sx--thing-as-string exclude))) (base . ,(if base base))))) - (let ((response (elt (sx-request-make - "filter/create" - keyword-arguments) 0))) - (sx-assoc-let response + (let ((result (elt (sx-request-make "filter/create" keyword-arguments) 0))) + (sx-assoc-let result .filter)))) @@ -93,7 +91,7 @@ Returns the compiled filter as a string." (defun sx-filter-get (&optional include exclude base) "Return the string representation of the given filter. -If the filter data exist in `sx--filter-alist', that value will +If the filter data exists in `sx--filter-alist', that value will be returned. Otherwise, compile INCLUDE, EXCLUDE, and BASE into a filter with `sx-filter-compile' and push the association onto `sx--filter-alist'. Re-cache the alist with `sx-cache-set' and @@ -128,8 +126,12 @@ return the compiled filter." question_id share_link) (user display_name + link + accept_rate reputation) (shallow_user display_name + link + accept_rate reputation) (comment owner body_markdown diff --git a/sx-inbox.el b/sx-inbox.el index 1efceb1..21589fb 100644 --- a/sx-inbox.el +++ b/sx-inbox.el @@ -69,6 +69,7 @@ KEYWORDS are added to the method call along with PAGE. `sx-method-call' is used with `sx-inbox-filter'." (sx-method-call (if notifications 'notifications 'inbox) :keywords keywords + :page page :filter sx-inbox-filter)) diff --git a/sx-interaction.el b/sx-interaction.el index 4d71c17..75b51ab 100644 --- a/sx-interaction.el +++ b/sx-interaction.el @@ -136,15 +136,28 @@ Element can be a question, answer, or comment." (save-excursion (yank)) (thing-at-point 'url)))) (list (read-string (concat "Link (" def "): ") nil nil def)))) - (let ((data (sx--link-to-data link))) - (sx-assoc-let data - (cl-case .type - (answer - (sx-display-question - (sx-question-get-from-answer .site_par .id) 'focus)) - (question - (sx-display-question - (sx-question-get-question .site_par .id) 'focus)))))) + ;; For now, we have no chance of handling chat links, let's just + ;; send them to the browser. + (if (string-match (rx string-start "http" (opt "s") "://chat.")) + (sx-visit-externally link) + (let ((data (sx--link-to-data link))) + (sx-assoc-let data + (cl-case .type + (comment + (sx-display-question + (sx-question-get-from-comment .site_par .id) 'focus) + (sx--find-in-buffer 'comment .id)) + (answer + (sx-display-question + (sx-question-get-from-answer .site_par .id) 'focus) + (sx--find-in-buffer 'answer .id)) + (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) + nil)))))) ;;; Displaying @@ -159,14 +172,35 @@ likes." (interactive (list (sx--data-here))) (sx-assoc-let data (cond - (.notification_type - (sx-message "Viewing notifications is not yet implemented")) - (.item_type (sx-open-link .link)) + ;; This is an attempt to identify when we have the question + ;; object itself, so there's no need to fetch anything. This + ;; happens inside the question-list, but it can be easily + ;; confused with the inbox (whose items have a title, a body, and + ;; a question_id). + ((and .title .question_id .score + (not .item_type) (not .notification_type)) + (sx-display-question data 'focus)) (.answer_id (sx-display-question - (sx-question-get-from-answer .site_par .id) 'focus)) - (.title - (sx-display-question data 'focus))))) + (sx-question-get-from-answer .site_par .answer_id) + 'focus) + (if .comment_id + (sx--find-in-buffer 'comment .comment_id) + (sx--find-in-buffer 'answer .answer_id))) + (.question_id + (sx-display-question + (sx-question-get-question .site_par .question_id) 'focus) + (when .comment_id + (sx--find-in-buffer 'comment .comment_id))) + ;; `sx-question-get-from-comment' takes 2 api requests, so we + ;; test it last. + (.comment_id + (sx-display-question + (sx-question-get-from-comment .site_par .comment_id) 'focus) + (sx--find-in-buffer 'comment .comment_id)) + (.notification_type + (sx-message "Viewing notifications is not yet implemented")) + (.item_type (sx-open-link .link))))) (defun sx-display-question (&optional data focus window) "Display question given by DATA, on WINDOW. @@ -272,7 +306,7 @@ TEXT is a string. Interactively, it is read from the minibufer." (setq text (read-string "Comment text: " (when .comment_id - (concat (sx--user-@name .owner) " ")))) + (substring-no-properties (sx-user--format "%@ " .owner))))) (while (not (sx--comment-valid-p text 'silent)) (setq text (read-string "Comment text (between 16 and 600 characters): " text)))) ;; If non-interactive, `text' could be anything. @@ -291,10 +325,8 @@ TEXT is a string. Interactively, it is read from the minibufer." ;; The api returns the new DATA. (when (> (length result) 0) (sx--add-comment-to-object - (elt result 0) - (if .post_id - (sx--get-post .post_type .site_par .post_id) - data)) + (sx--ensure-owner-in-object (list (cons 'display_name "(You)")) (elt result 0)) + (if .post_id (sx--get-post .post_type .site_par .post_id) data)) ;; Display the changes in `data'. (sx--maybe-update-display))))) @@ -344,7 +376,15 @@ OBJECT can be a question or an answer." (list comment))))) ;; No previous comments, add it manually. (setcdr object (cons (car object) (cdr object))) - (setcar object `(comments . [,comment]))))) + (setcar object `(comments . [,comment])))) + object) + +(defun sx--ensure-owner-in-object (owner object) + "Add `owner' property with value OWNER to OBJECT." + (unless (cdr-safe (assq 'owner object)) + (setcdr object (cons (car object) (cdr object))) + (setcar object `(owner . ,owner))) + object) ;;; Editing @@ -439,7 +479,8 @@ context at point. " (append (cdr cell) (list answer)))) ;; No previous comments, add it manually. (setcdr question (cons (car question) (cdr question))) - (setcar question `(answers . [,answer]))))) + (setcar question `(answers . [,answer]))) + question)) (provide 'sx-interaction) ;;; sx-interaction.el ends here diff --git a/sx-question-list.el b/sx-question-list.el index 41bebda..92b4c07 100644 --- a/sx-question-list.el +++ b/sx-question-list.el @@ -111,16 +111,6 @@ "" :group 'sx-question-list-faces) -(defface sx-question-list-reputation - '((t :inherit sx-question-list-date)) - "" - :group 'sx-question-list-faces) - -(defface sx-question-list-user - '((t :inherit font-lock-builtin-face)) - "" - :group 'sx-question-list-faces) - ;;; Backend variables (defvar sx-question-list--print-function #'sx-question-list--print-info @@ -138,8 +128,9 @@ change `tabulated-list-format' accordingly.") This is the default printer used by `sx-question-list'. It assumes QUESTION-DATA is an alist containing (at least) the elements: - `site', `score', `upvoted', `answer_count', `title', - `last_activity_date', `tags', `uestion_id'. + `question_id', `site_par', `score', `upvoted', `answer_count', + `title', `bounty_amount', `bounty_amount', `bounty_amount', + `last_activity_date', `tags', `owner'. Also see `sx-question-list-refresh'." (sx-assoc-let question-data @@ -182,11 +173,7 @@ Also see `sx-question-list-refresh'." (propertize (format "%-40s" (mapconcat #'sx-question--tag-format .tags " ")) 'face 'sx-question-list-tags) " " - (let-alist .owner - (format "%15s %5s" - (propertize (or .display_name "") 'face 'sx-question-list-user) - (propertize (number-to-string (or .reputation 0)) - 'face 'sx-question-list-reputation))) + (sx-user--format "%15d %4r" .owner) (propertize " " 'display "\n"))))))) (defvar sx-question-list--pages-so-far 0 diff --git a/sx-question-mode.el b/sx-question-mode.el index 5303ebb..6125416 100644 --- a/sx-question-mode.el +++ b/sx-question-mode.el @@ -121,10 +121,10 @@ Prefix argument N moves N sections down or up." (while (> count 0) ;; This will either move us to the next section, or move out of ;; the current one. - (unless (sx-question-mode--goto-property-change 'section n) + (unless (sx--goto-property-change 'sx-question-mode--section n) ;; If all we did was move out the current one, then move again ;; and we're guaranteed to reach the next section. - (sx-question-mode--goto-property-change 'section n)) + (sx--goto-property-change 'sx-question-mode--section n)) (unless (get-char-property (point) 'invisible) (cl-decf count)))) (when (equal (selected-window) (get-buffer-window)) @@ -140,22 +140,6 @@ Prefix argument moves N sections up or down." (interactive "p") (sx-question-mode-next-section (- (or n 1)))) -(defun sx-question-mode--goto-property-change (prop &optional direction) - "Move forward to the next change of text-property sx-question-mode--PROP. -Return the new value of PROP at point. - -If DIRECTION is negative, move backwards instead." - (let ((prop (intern (format "sx-question-mode--%s" prop))) - (func (if (and (numberp direction) - (< direction 0)) - #'previous-single-property-change - #'next-single-property-change)) - (limit (if (and (numberp direction) - (< direction 0)) - (point-min) (point-max)))) - (goto-char (funcall func (point) prop nil limit)) - (get-text-property (point) prop))) - (defun sx-question-mode-hide-show-section (&optional _) "Hide or show section under point. Optional argument _ is for `push-button'." diff --git a/sx-question-print.el b/sx-question-print.el index 031e06b..f9ecfab 100644 --- a/sx-question-print.el +++ b/sx-question-print.el @@ -26,6 +26,7 @@ (require 'sx) (require 'sx-question) (require 'sx-babel) +(require 'sx-user) (defgroup sx-question-mode nil "Customization group for sx-question-mode." @@ -33,20 +34,15 @@ :tag "SX Question Mode" :group 'sx) -(defgroup sx-question-mode-faces nil - "Customization group for the faces of `sx-question-mode'." +(defgroup sx-question-mode-faces '((sx-user custom-group)) + "Customization group for the faces of `sx-question-mode'. +Some faces of this mode might be defined in the `sx-user' group." :prefix "sx-question-mode-" :tag "SX Question Mode Faces" :group 'sx-question-mode) ;;; Faces and Variables -(defcustom sx-question-mode-deleted-user - '((display_name . "(deleted user)")) - "The structure used to represent a deleted account." - :type '(alist :options ((display_name string))) - :group 'sx-question-mode) - (defface sx-question-mode-header '((t :inherit font-lock-variable-name-face)) "Face used on the question headers in the question buffer." @@ -67,13 +63,9 @@ :type 'string :group 'sx-question-mode) -(defface sx-question-mode-author - '((t :inherit font-lock-string-face)) - "Face used on the question author in the question buffer." - :group 'sx-question-mode-faces) - -(defcustom sx-question-mode-header-author "\nAuthor: " - "String used before the question author at the header." +(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 :group 'sx-question-mode) @@ -92,11 +84,6 @@ "Face used on the question tags in the question buffer." :group 'sx-question-mode-faces) -(defface sx-question-mode-author - '((t :inherit font-lock-variable-name-face)) - "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." @@ -189,7 +176,7 @@ 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-list--sort-answer-function))) + (cl-sort .answers sx-question-mode-answer-sort-function))) (insert "\n\n ") (insert-text-button "Write an Answer" :type 'sx-button-answer) ;; Go up @@ -214,11 +201,13 @@ DATA can represent a question or an answer." ;; 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)) (sx-question-mode--insert-header - ;; Author - sx-question-mode-header-author - (sx-question-mode--propertize-display-name .owner) - 'sx-question-mode-author ;; Date sx-question-mode-header-date (concat @@ -226,8 +215,7 @@ DATA can represent a question or an answer." (when .last_edit_date (format sx-question-mode-last-edit-format (sx-time-since .last_edit_date) - (sx-question-mode--propertize-display-name - (or .last_editor sx-question-mode-deleted-user))))) + (sx-user--format "%d" .last_editor)))) 'sx-question-mode-date) (sx-question-mode--insert-header sx-question-mode-header-score @@ -283,12 +271,6 @@ DATA can represent a question or an answer." :type 'sx-button-comment) (insert "\n"))))) -(defun sx-question-mode--propertize-display-name (author) - "Return display_name of AUTHOR with `sx-question-mode-author' face." - (sx-assoc-let author - (propertize (or .display_name "??") - 'face 'sx-question-mode-author))) - (defun sx-question-mode--print-comment (comment-data) "Print the comment described by alist COMMENT-DATA. The comment is indented, filled, and then printed according to @@ -301,9 +283,8 @@ The comment is indented, filled, and then printed according to (if (eq .upvoted t) "^" "") " ")) (insert - (format - sx-question-mode-comments-format - (sx-question-mode--propertize-display-name .owner) + (format sx-question-mode-comments-format + (sx-user--format "%d" .owner) (substring ;; We fill with three spaces at the start, so the comment is ;; slightly indented. diff --git a/sx-question.el b/sx-question.el index e39634b..1df4900 100644 --- a/sx-question.el +++ b/sx-question.el @@ -19,7 +19,7 @@ ;;; Commentary: -;; Thie file provides an API for retrieving questions and defines +;; This file provides an API for retrieving questions and defines ;; additional logic for marking questions as read or hidden. @@ -72,6 +72,26 @@ If ANSWER-ID doesn't exist on SITE, raise an error." (error "Couldn't find answer %S in %S" answer-id site)))) +(defun sx-question-get-from-comment (site comment-id) + "Get question from SITE to which COMMENT-ID belongs. +If COMMENT-ID doesn't exist on SITE, raise an error. + +Note this requires two API requests. One for the comment and one +for the post." + (let ((res (sx-method-call 'comments + :id comment-id + :site site + :auth t + :filter sx-browse-filter))) + (unless (vectorp res) + (error "Couldn't find comment %S in %S" comment-id site)) + (sx-assoc-let (elt res 0) + (funcall (if (string= .post_type "answer") + #'sx-question-get-from-answer + #'sx-question-get-question) + .site_par + .post_id)))) + ;;; Question Properties diff --git a/sx-search.el b/sx-search.el index fa08e56..aefd12e 100644 --- a/sx-search.el +++ b/sx-search.el @@ -19,7 +19,7 @@ ;;; Commentary: -;; Implements sarch functionality. The basic function is +;; Implements search functionality. The basic function is ;; `sx-search-get-questions', which returns an array of questions ;; according to a search term. ;; diff --git a/sx-switchto.el b/sx-switchto.el index ed83360..6a195e0 100644 --- a/sx-switchto.el +++ b/sx-switchto.el @@ -33,7 +33,7 @@ (mapc (lambda (x) (define-key sx-switchto-map (car x) (cadr x))) '( - ;; These immitate the site's G hotkey. + ;; These imitate the site's G hotkey. ("a" sx-ask) ("h" sx-tab-frontpage) ("m" sx-tab-meta-or-main) diff --git a/sx-user.el b/sx-user.el new file mode 100644 index 0000000..c0f3a78 --- /dev/null +++ b/sx-user.el @@ -0,0 +1,203 @@ +;;; sx-user.el --- handling and printing user information -*- 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-button) + +(defgroup sx-user nil + "How users are displayed by SX." + :prefix "sx-user-" + :tag "SX User" + :group 'sx) + +(defcustom sx-question-mode-fallback-user + '( + (about_me . "") + (accept_rate . -1) + (account_id . -1) + (age . -1) + (answer_count . -1) + (badge_counts . ((bronze . -1) (silver . -1) (gold . -1))) + (creation_date . -1) + (display_name . "(unknown user)") + (down_vote_count . -1) + (is_employee . :json-false) + (last_access_date . -1) + (last_modified_date . -1) + (link . "") + (location . "") + (profile_image . ":(") + (question_count . -1) + (reputation . -1) + (reputation_change_day . -1) + (reputation_change_month . -1) + (reputation_change_quarter . -1) + (reputation_change_week . -1) + (reputation_change_year . -1) + (timed_penalty_date . -1) + (up_vote_count . -1) + (user_id . -1) + (user_type . does_not_exist) + (view_count . -1) + (website_url . "") + ) + "The structure used to represent missing user information. +NOOTE: SX relies on this variable containing all necessary user +information. You may edit any of its fields, but you'll run into +errors if you remove them." + :type '(alist :options ((about_me string) + (accept_rate integer) + (account_id integer) + (age integer) + (answer_count integer) + (badge_counts alist) + (creation_date integer) + (display_name string) + (down_vote_count integer) + (is_employee boolean) + (last_access_date integer) + (last_modified_date integer) + (link string) + (location string) + (profile_image string) + (question_count integer) + (reputation integer) + (reputation_change_day integer) + (reputation_change_month integer) + (reputation_change_quarter integer) + (reputation_change_week integer) + (reputation_change_year integer) + (timed_penalty_date integer) + (up_vote_count integer) + (user_id integer) + (user_type symbol) + (view_count integer) + (website_url string))) + :group 'sx-user) + + +;;; Text properties +(defface sx-user-name + '((t :inherit font-lock-builtin-face)) + "Face used for user names." + :group 'sx-user) + +(defface sx-user-reputation + '((t :inherit font-lock-comment-face)) + "Face used for user reputations." + :group 'sx-user) + +(defface sx-user-accept-rate + '((t)) + "Face used for user accept-rates." + :group 'sx-user) + +(defvar sx-user--format-property-alist + `((?d button ,(list t) category ,(button-category-symbol 'sx-button-user)) + (?n button ,(list t) category ,(button-category-symbol 'sx-button-user)) + (?@ button ,(list t) category ,(button-category-symbol 'sx-button-user)) + (?r face sx-user-reputation) + (?a face sx-user-accept-rate)) + "Alist relating % constructs with text properties. +See `sx-user--format'.") + + +;;; Formatting function +(defun sx-user--format (format-string user) + "Use FORMAT-STRING to format the user object USER. +The value is a copy of FORMAT-STRING, but with certain constructs +replaced by text that describes the specified USER: + +%d is the display name. +%@ is the display name in a format suitable for @mentions. +%l is the link to the profile. +%r is the reputation. +%a is the accept rate. + +The string replaced in each of these construct is also given the +text-properties specified in `sx-user--format-property-alist'. +Specially, %d and %@ are turned into buttons with the +`sx-button-user' category." + (sx-assoc-let (append user sx-question-mode-fallback-user) + (let* ((text (sx-format-replacements + format-string + `((?d . ,\.display_name) + (?n . ,\.display_name) + (?l . ,\.link) + (?r . ,\.reputation) + (?a . ,\.accept_rate) + (?@ . ,(when (string-match "%@" format-string) + (sx-user--@name .display_name))) + ) + sx-user--format-property-alist))) + (if (< 0 (string-width .link)) + (propertize text + ;; For visiting and stuff. + 'sx-button-url .link + 'sx-button-copy .link) + text)))) + + +;;; @name conversion +(defconst sx-user--ascii-replacement-list + '(("[:space:]" . "") + ("àåáâäãåą" . "a") + ("èéêëę" . "e") + ("ìíîïı" . "i") + ("òóôõöøőð" . "o") + ("ùúûüŭů" . "u") + ("çćčĉ" . "c") + ("żźž" . "z") + ("śşšŝ" . "s") + ("ñń" . "n") + ("ýÿ" . "y") + ("ğĝ" . "g") + ("ř" . "r") + ("ł" . "l") + ("đ" . "d") + ("ß" . "ss") + ("Þ" . "th") + ("ĥ" . "h") + ("ĵ" . "j") + ("^[:ascii:]" . "")) + "List of replacements to use for non-ascii characters. +Used to convert user names into @mentions.") + +(defun sx-user--@name (display-name) + "Convert DISPLAY-NAME into an @mention. +In order to correctly @mention the user, all whitespace is +removed from DISPLAY-NAME and a series of unicode conversions are +performed before it is returned. +See `sx-user--ascii-replacement-list'. + +If all you need is the @name, this is very slightly faster than +using `sx-user--format', but it doesn't do any sanity checking." + (concat "@" (sx--recursive-replace + sx-user--ascii-replacement-list display-name))) + +(provide 'sx-user) +;;; sx-user.el ends here + +;; Local Variables: +;; indent-tabs-mode: nil +;; End: @@ -92,46 +92,70 @@ with a `link' property)." "Convert string LINK into data that can be displayed." (let ((result (list (cons 'site_par (sx--site link))))) ;; Try to strip a question or answer ID - (when (or + (when (cond ;; Comment + ((or ;; If there's a #commentNUMBER_NUMBER at the end, we + ;; know it's a comment with that ID. + (string-match (rx "#comment" (group-n 1 (+ digit)) + "_" (+ digit) string-end) + link) + ;; From inbox items + (string-match (rx "/posts/comments/" + ;; Comment ID + (group-n 1 (+ digit)) + ;; Optional stuff at the end + (or (and (any "?#") (* any)) "") + string-end) + link)) + (push '(type . comment) result)) ;; Answer - (and (or (string-match - ;; From 'Share' button - (rx "/a/" - ;; Question ID - (group (+ digit)) - ;; User ID - "/" (+ digit) - ;; Answer ID - (group (or (sequence "#" (* any)) "")) - string-end) link) - (string-match - ;; From URL - (rx "/questions/" (+ digit) "/" - (+ (not (any "/"))) "/" - ;; User ID - (optional (group (+ digit))) - (optional "/") - (group (or (sequence "#" (* any)) "")) - string-end) link)) - (push '(type . answer) result)) + ((or ;; If there's a #NUMBER at the end, we know it's an + ;; answer with that ID. + (string-match (rx "#" (group-n 1 (+ digit)) string-end) link) + ;; From 'Share' button + (string-match (rx "/a/" + ;; Answer ID + (group-n 1 (+ digit)) "/" + ;; User ID + (+ digit) + ;; Garbage at the end + (optional (and (any "?#") (* any))) + string-end) + link) + ;; From URL + (string-match (rx "/questions/" (+ digit) "/" + ;; Question title + (+ (not (any "/"))) "/" + ;; Answer ID. If this is absent, we match on + ;; Question clause below. + (group-n 1 (+ digit)) + (opt "/") + ;; Garbage at the end + (optional (and (any "?#") (* any))) + string-end) + link)) + (push '(type . answer) result)) ;; Question - (and (or (string-match - ;; From 'Share' button - (rx "/q/" - ;; Question ID - (group (+ digit)) - ;; User ID - (optional "/" (+ digit)) - ;; Answer or Comment ID - (group (or (sequence "#" (* any)) "")) - string-end) link) - (string-match - ;; From URL - (rx "/questions/" - ;; Question ID - (group (+ digit)) - "/") link)) - (push '(type . question) result))) + ((or ;; From 'Share' button + (string-match (rx "/q/" + ;; Question ID + (group-n 1 (+ digit)) + ;; User ID + (optional "/" (+ digit)) + ;; Garbage at the end + (optional (and (any "?#") (* any))) + string-end) + link) + ;; From URL + (string-match (rx "/questions/" + ;; Question ID + (group-n 1 (+ digit)) "/" + ;; Optional question title + (optional (+ (not (any "/"))) "/") + ;; Garbage at the end + (optional (and (any "?#") (* any))) + string-end) + link)) + (push '(type . question) result))) (push (cons 'id (string-to-number (match-string-no-properties 1 link))) result)) result)) @@ -259,6 +283,48 @@ whenever BODY evaluates to nil." :filter (lambda (&optional _) (when (progn ,@body) ,def))))) +(defun sx--goto-property-change (prop &optional direction) + "Move forward to the next change of text-property PROP. +Return the new value of PROP at point. + +If DIRECTION is negative, move backwards instead." + (let ((func (if (and (numberp direction) + (< direction 0)) + #'previous-single-property-change + #'next-single-property-change)) + (limit (if (and (numberp direction) + (< direction 0)) + (point-min) (point-max)))) + (goto-char (funcall func (point) prop nil limit)) + (get-text-property (point) prop))) + +(defun sx--find-in-buffer (type id) + "Move point to an object of TYPE and ID. +That is, move forward from beginning of buffer until +`sx--data-here' is an object of type TYPE with the respective id +ID. If point is left at the of a line, move over the line break. + +TYPE is either question, answer, or comment. +ID is an integer." + (let* ((id-symbol (cl-case type + (answer 'answer_id) + (comment 'comment_id) + (question 'question_id))) + (pos + (save-excursion + (goto-char (point-min)) + (while (not (or (eobp) + (let ((data (sx--data-here type t))) + (and data + (= id (or (cdr (assq id-symbol data)))))))) + (forward-char 1)) + (point)))) + (if (equal pos (point-max)) + (sx-message "Can't find the specified %s" type) + (goto-char pos) + (when (looking-at-p "$") + (forward-char 1))))) + (defmacro sx--create-comparator (name doc compare-func get-func) "Define a new comparator called NAME with documentation DOC. COMPARE-FUNC is a function that takes the return value of @@ -305,39 +371,6 @@ Return the result of BODY." (push ov sx--overlays)) result)) -(defconst sx--ascii-replacement-list - '(("[:space:]" . "") - ("àåáâäãåą" . "a") - ("èéêëę" . "e") - ("ìíîïı" . "i") - ("òóôõöøőð" . "o") - ("ùúûüŭů" . "u") - ("çćčĉ" . "c") - ("żźž" . "z") - ("śşšŝ" . "s") - ("ñń" . "n") - ("ýÿ" . "y") - ("ğĝ" . "g") - ("ř" . "r") - ("ł" . "l") - ("đ" . "d") - ("ß" . "ss") - ("Þ" . "th") - ("ĥ" . "h") - ("ĵ" . "j") - ("^[:ascii:]" . "")) - "List of replacements to use for non-ascii characters. -Used to convert user names into @mentions.") - -(defun sx--user-@name (user) - "Get the `display_name' of USER prepended with @. -In order to correctly @mention the user, all whitespace is -removed from the display name before it is returned." - (sx-assoc-let user - (when (stringp .display_name) - (concat "@" (sx--recursive-replace - sx--ascii-replacement-list .display_name))))) - (defun sx--recursive-replace (alist string) "Replace each car of ALIST with its cdr in STRING." (if alist @@ -348,6 +381,44 @@ removed from the display name before it is returned." (format "[%s]" (car kar)) (cdr kar) string))) string)) +(defun sx-format-replacements (format alist &optional property-alist) + "Use FORMAT-STRING to format the values in ALIST. +ALIST is a list with elements of the form (CHAR . STRING). +The value is a copy of FORMAT-STRING, but with certain constructs +replaced by text as given by ALIST. + +The construct is a `%' character followed by any other character. +The replacement is the STRING corresponding to CHAR in ALIST. In +addition, if CHAR is also the car of an element in +PROPERTY-ALIST, the cdr of that element should be a list of text +properties which will be applied on the replacement. + +The %% construct is special, it is replaced with a single %, even +if ALIST contains a different string at the ?% entry." + (let ((alist (cons '(?% . "%") alist))) + (with-temp-buffer + (insert format) + (goto-char (point-min)) + (while (search-forward-regexp + (rx "%" (group-n 1 (* (any "-+ #0-9.")))) nil 'noerror) + (let* ((char (char-after)) + ;; Understand flags + (flag (match-string 1)) + (val (cdr-safe (assq char alist)))) + (unless val + (error "Invalid format character: `%%%c'" char)) + ;; Insert first, to preserve text properties. + (insert-and-inherit (format (concat "%" flag "s") val)) + (when property-alist + (add-text-properties (match-end 0) (point) + (cdr-safe (assq char property-alist)))) + ;; Delete the specifier body. + (delete-region (match-beginning 0) + (match-end 0)) + ;; Delete `char-after'. + (delete-char 1))) + (buffer-string)))) + (defcustom sx-init-hook nil "Hook run when SX initializes. @@ -97,7 +97,7 @@ Scrolling past the bottom of the list fetches more questions. - ~sx-init-hook~ :: Run when ~sx-initialize~ is called. - ~sx-compose-before-send-hook~ :: Run before POSTing to the API from a buffer in ~sx-compose-mode~. If any of the functions in this - hook, return nil, the transaction is cancelled. + hook, return nil, the transaction is canceled. - ~sx-compose-after-send-functions~ :: Run after POSTing to the API from a buffer in ~sx-compose-mode~, if the transaction was successful. @@ -156,44 +156,45 @@ has a descriptive header explaining its purpose. Still, to help you find your way around, we describe below the current project structure. This list is very loosely ordered form low to high-level. -- ~sx.el~ - Utility functions used throughout the package. Essentially - every file indirectly requires this one. If you're adding a function - that's used by different parts of the package, add it to this file. -- ~sx-time.el~ - Similar to ~sx.el~, but only contains a few - time-related functions. -- ~sx-filter.el~ - Handles retrieval of filters. -- ~sx-cache.el~ - Saves and restores persistent data between sessions. -- ~sx-button.el~ - Defines all button types used throughout the - package. Currently used only by ~sx-question-print.el~. - -- ~sx-request.el~ - Requests and url manipulation. Backend used by - ~sx-method.el~. It shouldn't be necessary to use the functions in - this file outside ~sx-method.el~. -- ~sx-method.el~ - Main interface for API method calls. - -- ~sx-favorites.el~ - Starred questions. -- ~sx-networks.el~ - User network information. -- ~sx-site.el~ - Browsing sites. -- ~sx-auth.el~ - Handles user authentication. - -- ~sx-question.el~ - Base question logic. Holds several functions for - retrieving questions and for processing retrieved questions. Doesn't - do any sort of user interface, that is left for - ~sx-question-list.el~ and ~sx-question-mode.el~. -- ~sx-question-list.el~ - Major-mode for navigating questions list. -- ~sx-question-mode.el~ - User interface for displaying a - question. Creates the buffer and defines the major-mode. -- ~sx-question-print.el~ - Populating the question buffer with - content. Used by ~sx-question-mode.el~ to actually print the content - of a question. -- ~sx-babel.el~ - Font-locking code blocks printed by - ~sx-question-print.el~ according to the language. - -- ~sx-compose.el~ - Major-mode for composing questions and answers. -- ~sx-interaction.el~ - Voting, commenting, and otherwise interacting with questions. -- ~sx-tab.el~ - Functions for viewing different tabs. - -- ~sx-load.el~ - Load all files of the sx package. Designed as an easy way in for users who install the package manually (since they don't have autoloads). +- ~sx.el~ :: Utility functions used throughout the + package. Essentially every file indirectly requires this + one. If you're adding a function that's used by different + parts of the package, add it to this file. +- ~sx-time.el~ :: Similar to ~sx.el~, but only contains a few + time-related functions. +- ~sx-filter.el~ :: Handles retrieval of filters. +- ~sx-cache.el~ :: Saves and restores persistent data between + sessions. +- ~sx-button.el~ :: Defines all button types used throughout the + package. Currently used only by + ~sx-question-print.el~. +- ~sx-request.el~ :: Requests and url manipulation. Back-end used by + ~sx-method.el~. It shouldn't be necessary to use the functions in + this file outside ~sx-method.el~. +- ~sx-method.el~ :: Main interface for API method calls. +- ~sx-favorites.el~ :: Starred questions. +- ~sx-networks.el~ :: User network information. +- ~sx-site.el~ :: Browsing sites. +- ~sx-auth.el~ :: Handles user authentication. +- ~sx-question.el~ :: Base question logic. Holds several functions for + retrieving questions and for processing retrieved + questions. Doesn't do any sort of user interface, that is left + for ~sx-question-list.el~ and ~sx-question-mode.el~. +- ~sx-question-list.el~ :: Major-mode for navigating questions list. +- ~sx-question-mode.el~ :: User interface for displaying a + question. Creates the buffer and defines the major-mode. +- ~sx-question-print.el~ :: Populating the question buffer with + content. Used by ~sx-question-mode.el~ to actually print the + content of a question. +- ~sx-babel.el~ :: Font-locking code blocks printed by + ~sx-question-print.el~ according to the language. +- ~sx-compose.el~ :: Major-mode for composing questions and answers. +- ~sx-interaction.el~ :: Voting, commenting, and otherwise interacting + with questions. +- ~sx-tab.el~ :: Functions for viewing different tabs. +- ~sx-load.el~ :: Load all files of the SX package. Designed as an + easy way in for users who install the package + manually (since they don't have autoloads). * COMMENT Local Variables # LocalWords: StackExchange SX inbox sx API url json inline Org diff --git a/test/test-macros.el b/test/test-macros.el index 1634603..5e0eac9 100644 --- a/test/test-macros.el +++ b/test/test-macros.el @@ -39,6 +39,5 @@ .page .page_size .quota_max - .quota_remaining - .total) - nil none)))) + .quota_remaining) + nil nil)))) diff --git a/test/test-printing.el b/test/test-printing.el index c477b28..7384829 100644 --- a/test/test-printing.el +++ b/test/test-printing.el @@ -64,13 +64,76 @@ after being run through `sx-question--tag-format'." "Test `sx--user-@name' character substitution" (should (string= - (sx--user-@name '((display_name . "ĥÞßđłřğĝýÿñńśşšŝżźžçćčĉùúûüŭůòóôõöøőðìíîïıèéêëęàåáâäãåąĵ★"))) + (sx-user--@name "ĥÞßđłřğĝýÿñńśşšŝżźžçćčĉùúûüŭůòóôõöøőðìíîïıèéêëęàåáâäãåąĵ★") "@hTHssdlrggyynnsssszzzccccuuuuuuooooooooiiiiieeeeeaaaaaaaaj")) (should (string= - (sx--user-@name '((display_name . "ĤÞßĐŁŘĞĜÝŸÑŃŚŞŠŜŻŹŽÇĆČĈÙÚÛÜŬŮÒÓÔÕÖØŐÐÌÍÎÏıÈÉÊËĘÀÅÁÂÄÃÅĄĴ"))) + (sx-user--@name "ĤÞßĐŁŘĞĜÝŸÑŃŚŞŠŜŻŹŽÇĆČĈÙÚÛÜŬŮÒÓÔÕÖØŐÐÌÍÎÏıÈÉÊËĘÀÅÁÂÄÃÅĄĴ") + "@HTHssDLRGGYYNNSSSSZZZCCCCUUUUUUOOOOOOOOIIIIiEEEEEAAAAAAAAJ")) + (should-error + (sx-user--@name 2))) + +(ert-deftest sx-user--format () + "Test various `sx-user--format' features." + (let ((user + '((display_name . "ĥÞßđłřğĝýÿñńśşšŝżźžçćčĉùúûüŭůòóôõöøőðìíîïıèéêëęàåáâäãåąĵ★") + (accept_rate . 90) + (reputation . 10) + (link . "link")))) + (should + (equal (sx-user--format "%l" user) "link")) + (should + (equal + (sx-user--format "%@" user) + "@hTHssdlrggyynnsssszzzccccuuuuuuooooooooiiiiieeeeeaaaaaaaaj")) + (should + (equal + (sx-user--format "%@%%d%%%-30d %9r%l" user) + "@hTHssdlrggyynnsssszzzccccuuuuuuooooooooiiiiieeeeeaaaaaaaaj%d%ĥÞßđłřğĝýÿñńśşšŝżźžçćčĉùúûüŭůòóôõöøőðìíîïıèéêëęàåáâäãåąĵ★ 10link"))) + (should + (string= + (sx-user--format "%@" '((display_name . "ĤÞßĐŁŘĞĜÝŸÑŃŚŞŠŜŻŹŽÇĆČĈÙÚÛÜŬŮÒÓÔÕÖØŐÐÌÍÎÏıÈÉÊËĘÀÅÁÂÄÃÅĄĴ"))) "@HTHssDLRGGYYNNSSSSZZZCCCCUUUUUUOOOOOOOOIIIIiEEEEEAAAAAAAAJ"))) +(ert-deftest sx-object-modification () + "Test adding things to objects" + (let ((object (list (cons 'owner "me")))) + (should + (equal (sx--ensure-owner-in-object 1 object) + '((owner . "me")))) + (should + (equal object '((owner . "me"))))) + (let ((object (list (cons 'not-owner "me")))) + (should + (equal (sx--ensure-owner-in-object 1 object) + '((owner . 1) (not-owner . "me")))) + (should + (equal object '((owner . 1) (not-owner . "me"))))) + (let ((object (list (cons 'comments [something])))) + (should + (equal (sx--add-comment-to-object "comment" object) + '((comments . [something "comment"])))) + (should + (equal object '((comments . [something "comment"]))))) + (let ((object (list (cons 'not-comments [something])))) + (should + (equal (sx--add-comment-to-object "comment" object) + '((comments . ["comment"]) (not-comments . [something])))) + (should + (equal object '((comments . ["comment"]) (not-comments . [something]))))) + (let ((object (list (cons 'not-answers [something])))) + (should + (equal (sx--add-answer-to-question-object "answer" object) + '((answers . ["answer"]) (not-answers . [something])))) + (should + (equal object '((answers . ["answer"]) (not-answers . [something]))))) + (let ((object (list (cons 'answers [something])))) + (should + (equal (sx--add-answer-to-question-object "answer" object) + '((answers . [something "answer"])))) + (should + (equal object '((answers . [something "answer"])))))) + (ert-deftest sx-question-mode--fill-and-fontify () "Check complicated questions are filled correctly." (should diff --git a/test/test-util.el b/test/test-util.el index 1e3dc2b..b466c08 100644 --- a/test/test-util.el +++ b/test/test-util.el @@ -43,3 +43,29 @@ (lambda (path) (intern (mapconcat #'symbol-name path "/"))) '(a b (c d (e f g) h i (j k) l) m (n o) p)) '(a b c/d c/e/f c/e/g c/h c/i c/j/k c/l m n/o p)))) + +(ert-deftest link-to-data () + (should + (equal + (sx--link-to-data "http://meta.emacs.stackexchange.com/posts/comments/510?noredirect=1") + '((id . 510) (type . comment) (site_par . "meta.emacs")))) + (should + (equal + (sx--link-to-data "http://emacs.stackexchange.com/questions/7409/is-there-a-generic-toggle-previous-window-function#comment10965_7409") + '((id . 10965) (type . comment) (site_par . "emacs")))) + (should + (equal + (sx--link-to-data "http://emacs.stackexchange.com/q/7409/50") + '((id . 7409) (type . question) (site_par . "emacs")))) + (should + (equal + (sx--link-to-data "http://emacs.stackexchange.com/a/7410/50") + '((id . 7410) (type . answer) (site_par . "emacs")))) + (should + (equal + (sx--link-to-data "http://emacs.stackexchange.com/questions/7409/is-there-a-generic-toggle-previous-window-function/9999#7410") + '((id . 7410) (type . answer) (site_par . "emacs")))) + (should + (equal + (sx--link-to-data "http://emacs.stackexchange.com/questions/7409/is-there-a-generic-toggle-previous-window-function/7410") + '((id . 7410) (type . answer) (site_par . "emacs"))))) |