diff options
| -rw-r--r-- | sx-button.el | 129 | ||||
| -rw-r--r-- | sx-interaction.el | 15 | ||||
| -rw-r--r-- | sx-question-mode.el | 16 | ||||
| -rw-r--r-- | sx-question-print.el | 129 | ||||
| -rw-r--r-- | sx-tab.el | 1 | ||||
| -rw-r--r-- | sx.el | 62 |
6 files changed, 270 insertions, 82 deletions
diff --git a/sx-button.el b/sx-button.el new file mode 100644 index 0000000..c1abf90 --- /dev/null +++ b/sx-button.el @@ -0,0 +1,129 @@ +;;; sx-button.el --- Defining buttons used throughout SX. + +;; 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 'button) + +(require 'sx) +(require 'sx-question) + + +;;; Command definitions +;; This extends `button-map', which already defines RET and mouse-1. +(defvar sx-button-map + (let ((map (copy-keymap button-map))) + (define-key map "w" #'sx-button-copy) + map) + "Keymap used on buttons.") + +(defun sx-button-copy () + "Copy the content of thing at point. +This is usually a link's URL, or the content of a code block." + (interactive) + (let ((content + (get-text-property (point) 'sx-button-copy))) + (if (null content) + (sx-message "Nothing to copy here.") + (kill-new content) + (sx-message "Copied %s to kill ring." + (or (get-text-property + (point) 'sx-button-copy-type) + content))))) + +(defun sx-button-edit-this (text-or-marker) + "Open a temp buffer populated with the string TEXT-OR-MARKER. +When given a marker (or interactively), use the 'sx-button-copy +text-property under the marker. This is usually the content of a +code-block." + (interactive (list (point-marker))) + ;; Buttons receive markers. + (when (markerp text-or-marker) + (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))) + +(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) + (user-error "No url under point: %s" (or pos (point)))))) + + +;;; Help-echo definitions +(defvar 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 + (format sx-button--help-echo + (propertize "hide content" 'face 'minibuffer-prompt) + (propertize "link" 'face 'minibuffer-prompt)) + "Help echoed in the minibuffer when point is on a section.") + +(defvar sx-button--link-help-echo + (format sx-button--help-echo + (propertize "visit %s" 'face 'minibuffer-prompt) + (propertize "URL" 'face 'minibuffer-prompt)) + "Help echoed in the minibuffer when point is on a section.") + + +;;; Type definitions +(define-button-type 'sx-button + 'follow-link t + 'keymap sx-button-map) + +(define-button-type 'sx-question-mode-title + 'face 'sx-question-mode-title + 'action #'sx-question-mode-hide-show-section + 'help-echo sx-button--question-title-help-echo + 'sx-button-copy-type "Share Link" + :supertype 'sx-button) + +(define-button-type 'sx-question-mode-code-block + 'action #'sx-button-edit-this + 'face nil + :supertype 'sx-button) + +(define-button-type 'sx-button-link + 'action #'sx-button-follow-link + :supertype 'sx-button) + +(define-button-type 'sx-button-comment + 'help-echo (concat "mouse-1, RET" + (propertize ": write a comment" + 'face 'minibuffer-prompt)) + 'action #'sx-comment + :supertype 'sx-button) + +(provide 'sx-button) +;;; sx-button.el ends here + +;; Local Variables: +;; lexical-binding: t +;; End: diff --git a/sx-interaction.el b/sx-interaction.el index 5f3ece6..305e61c 100644 --- a/sx-interaction.el +++ b/sx-interaction.el @@ -31,11 +31,11 @@ ;;; Using data in buffer (defun sx--data-here () "Get the text property `sx--data-here'." - (or (get-text-property (point) 'sx--data-here) + (or (get-char-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))) + (and (derived-mode-p 'sx-question-mode) + sx-question-mode--data))) (defun sx--maybe-update-display () "Refresh the question list if we're inside it." @@ -117,15 +117,18 @@ changes." ;;; Commenting -(defun sx-comment (data text) +(defun sx-comment (data &optional text) "Post a comment on DATA given by TEXT. DATA can be a question, an answer, or a comment. Interactively, it is guessed from context at point. 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--data-here) 'query)) + (interactive (list (sx--data-here) 'query)) + ;; When clicking the "Add a Comment" button, first arg is a marker. + (when (markerp data) + (setq data (sx--data-here)) + (setq text 'query)) (sx-assoc-let data ;; Get the comment text (when (eq text 'query) diff --git a/sx-question-mode.el b/sx-question-mode.el index 01a980a..c44519c 100644 --- a/sx-question-mode.el +++ b/sx-question-mode.el @@ -82,7 +82,7 @@ If WINDOW is given, use that to display the buffer." ;; To move between sections, just search for the property. The value ;; of the text-property is the depth of the section (1 for contents, 2 ;; for comments). -(defcustom sx-question-mode-recenter-line 1 +(defcustom sx-question-mode-recenter-line 2 "Screen line to which we recenter after moving between sections. This is used as an argument to `recenter', only used if the end of section is outside the window. @@ -141,9 +141,9 @@ If DIRECTION is negative, move backwards instead." "Hide or show section under point. Optional argument _ is for `push-button'." (interactive) - (let ((ov (car (or (sx-question-mode--section-overlays-at (point)) - (sx-question-mode--section-overlays-at - (line-end-position)))))) + (let ((ov (or (sx-question-mode--section-overlays-at + (line-end-position)) + (sx-question-mode--section-overlays-at (point))))) (goto-char (overlay-start ov)) (forward-line 0) (overlay-put @@ -151,9 +151,11 @@ Optional argument _ is for `push-button'." (null (overlay-get ov 'invisible))))) (defun sx-question-mode--section-overlays-at (pos) - "Return a list of `sx-question-mode--section-content' overlays at POS." - (cl-remove-if (lambda (x) (null (overlay-get x 'sx-question-mode--section-content))) - (overlays-at pos))) + "Return the highest priority section overlay at POS. +A section overlay has a `sx-question-mode--section-content' +property." + (cdr-safe (get-char-property-and-overlay + pos 'sx-question-mode--section-content nil))) ;;; Major-mode diff --git a/sx-question-print.el b/sx-question-print.el index 9245331..4655f5e 100644 --- a/sx-question-print.el +++ b/sx-question-print.el @@ -22,7 +22,7 @@ ;;; Code: (require 'markdown-mode) -(require 'button) +(require 'sx-button) (eval-when-compile (require 'rx)) @@ -43,6 +43,11 @@ ;;; 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)) @@ -164,26 +169,8 @@ replaced with the comment." :group 'sx-question-mode) -;;; Buttons -(define-button-type 'sx-question-mode-title - 'face 'sx-question-mode-title - 'action #'sx-question-mode-hide-show-section - 'help-echo 'sx-question-mode--section-help-echo - 'follow-link t) - -(define-button-type 'sx-question-mode-link - 'follow-link t - 'action #'sx-question-mode-follow-link) - - ;;; Functions ;;;; Printing the general structure -(defvar sx-question-mode--section-help-echo - (format - (propertize "%s to hide/display content" 'face 'minibuffer-prompt) - (propertize "RET" 'face 'font-lock-function-name-face)) - "Help echoed in the minibuffer when point is on a section.") - (defun sx-question-mode--print-question (question) "Print a buffer describing QUESTION. QUESTION must be a data structure returned by `json-read'." @@ -207,7 +194,7 @@ QUESTION must be a data structure returned by `json-read'." DATA can represent a question or an answer." ;; This makes `data' accessible through `sx--data-here'. (sx-assoc-let data - (sx--wrap-in-text-property + (sx--wrap-in-overlay (list 'sx--data-here data) (insert sx-question-mode-header-title) (insert-text-button @@ -215,6 +202,7 @@ DATA can represent a question or an answer." (or .title sx-question-mode-answer-title) ;; Section level 'sx-question-mode--section (if .title 1 2) + 'sx-button-copy .share_link :type 'sx-question-mode-title) ;; Sections can be hidden with overlays (sx--wrap-in-overlay @@ -231,7 +219,8 @@ 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 .last_editor)))) + (sx-question-mode--propertize-display-name + (or .last_editor sx-question-mode-deleted-user))))) 'sx-question-mode-date) (sx-question-mode--insert-header sx-question-mode-header-score @@ -258,22 +247,35 @@ DATA can represent a question or an answer." .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 - :type 'sx-question-mode-title) - (sx--wrap-in-overlay - '(sx-question-mode--section-content t) - (insert "\n") - (sx--wrap-in-overlay - '(face sx-question-mode-content-face) - (mapc #'sx-question-mode--print-comment .comments)))))) + '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) + (insert "\n") + (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. + (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" + :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." @@ -285,7 +287,7 @@ DATA can represent a question or an answer." "Print the comment described by alist COMMENT-DATA. The comment is indented, filled, and then printed according to `sx-question-mode-comments-format'." - (sx--wrap-in-text-property + (sx--wrap-in-overlay (list 'sx--data-here comment-data) (sx-assoc-let comment-data (insert @@ -367,7 +369,7 @@ E.g.: (defun sx-question-mode--dont-fill-here () "If text shouldn't be filled here, return t and skip over it." - (or (sx-question-mode--move-over-pre) + (or (sx-question-mode--skip-and-fontify-pre) ;; Skip headers and references (let ((pos (point))) (skip-chars-forward "\r\n[:blank:]") @@ -403,19 +405,13 @@ URL is used as 'help-echo and 'url properties." text ;; Mouse-over 'help-echo - (format (propertize "URL: %s, %s to visit" 'face 'minibuffer-prompt) - (propertize url 'face 'default) - (propertize "RET" 'face 'font-lock-function-name-face)) + (format sx-button--link-help-echo + (propertize (sx--shorten-url url) + 'face 'font-lock-function-name-face)) ;; For visiting and stuff. - 'url url - :type 'sx-question-mode-link)) - -(defun sx-question-mode-follow-link (&optional pos) - "Follow link at POS. If POS is nil, use `point'." - (interactive) - (browse-url - (or (get-text-property (or pos (point)) 'url) - (user-error "No url under point: %s" (or pos (point)))))) + 'sx-button-url url + 'sx-button-copy url + :type 'sx-button-link)) (defun sx-question-mode-find-reference (id &optional fallback-id) "Find url identified by reference ID in current buffer. @@ -425,16 +421,33 @@ If ID is nil, use FALLBACK-ID instead." (goto-char (point-min)) (when (search-forward-regexp (format sx-question-mode--reference-regexp - (or id fallback-id)) + (or id fallback-id)) nil t) (match-string-no-properties 1))))) -(defun sx-question-mode--move-over-pre () - "Non-nil if paragraph at point can be filled." - (markdown-match-pre-blocks - (save-excursion - (skip-chars-forward "\r\n[:blank:]") - (point)))) +(defun sx-question-mode--skip-and-fontify-pre () + "If there's a pre block ahead, handle it, skip it and return t. +Handling means to turn it into a button and remove erroneous +font-locking." + (let (beg end text) + (when (markdown-match-pre-blocks + (save-excursion + (skip-chars-forward "\r\n[:blank:]") + (setq beg (point)))) + (setq end (point)) + (setq text + (sx--unindent-text + (buffer-substring + (save-excursion + (goto-char beg) + (line-beginning-position)) + end))) + (put-text-property beg end 'display nil) + (make-text-button + beg end + 'face 'markdown-pre-face + 'sx-button-copy text + :type 'sx-question-mode-code-block)))) (provide 'sx-question-print) ;;; sx-question-print.el ends here @@ -26,6 +26,7 @@ (require 'sx) (require 'sx-question-list) +(require 'sx-interaction) (defcustom sx-tab-default-site "emacs" "Name of the site to use by default when listing questions." @@ -63,6 +63,7 @@ question.upvoted question.downvoted question.question_id + question.share_link user.display_name comment.owner comment.body_markdown @@ -78,6 +79,7 @@ answer.answer_id answer.last_editor answer.link + answer.share_link answer.owner answer.body_markdown answer.upvoted @@ -171,12 +173,53 @@ would yield cons-cell)))) data)))) +(defun sx--shorten-url (url) + "Shorten URL hiding anything other than the domain. +Paths after the domain are replaced with \"...\". +Anything before the (sub)domain is removed." + (replace-regexp-in-string + ;; Remove anything after domain. + (rx (group-n 1 (and (1+ (any word ".")) "/")) + (1+ anything) string-end) + (eval-when-compile + (concat "\\1" (if (char-displayable-p ?…) "…" "..."))) + ;; Remove anything before subdomain. + (replace-regexp-in-string + (rx string-start (or (and (0+ word) (optional ":") "//"))) + "" url))) + +(defun sx--unindent-text (text) + "Remove indentation from TEXT." + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (let (result) + (while (null (eobp)) + (skip-chars-forward "[:blank:]") + (unless (looking-at "$") + (push (current-column) result)) + (forward-line 1)) + (when result + (let ((rx (format "^ \\{0,%s\\}" + (apply #'min result)))) + (goto-char (point-min)) + (while (and (null (eobp)) + (search-forward-regexp rx nil 'noerror)) + (replace-match "") + (forward-line 1))))) + (buffer-string))) + ;;; Printing request data (defvar sx--overlays nil "Overlays created by sx on this buffer.") (make-variable-buffer-local 'sx--overlays) +(defvar sx--overlay-printing-depth 0 + "Track how many overlays we're printing on top of each other. +Used for assigning higher priority to inner overlays.") +(make-variable-buffer-local 'sx--overlay-printing-depth) + (defmacro sx--wrap-in-overlay (properties &rest body) "Start a scope with overlay PROPERTIES and execute BODY. Overlay is pushed on the buffer-local variable `sx--overlays' and @@ -186,24 +229,21 @@ Return the result of BODY." (declare (indent 1) (debug t)) `(let ((p (point-marker)) - (result (progn ,@body))) + (result (progn ,@body)) + ;; The first overlay is the shallowest. Any overlays created + ;; while the first one is still being created go deeper and + ;; deeper. + (sx--overlay-printing-depth (1+ sx--overlay-printing-depth))) (let ((ov (make-overlay p (point))) (props ,properties)) (while props (overlay-put ov (pop props) (pop props))) + ;; Let's multiply by 10 just in case we ever want to put + ;; something in the middle. + (overlay-put ov 'priority (* 10 sx--overlay-printing-depth)) (push ov sx--overlays)) result)) -(defmacro sx--wrap-in-text-property (properties &rest body) - "Start a scope with PROPERTIES and execute BODY. -Return the result of BODY." - (declare (indent 1) - (debug t)) - `(let ((p (point-marker)) - (result (progn ,@body))) - (add-text-properties p (point) ,properties) - result)) - (defun sx--user-@name (user) "Get the `display_name' of USER prepended with @. In order to correctly @mention the user, all whitespace is |