diff options
| -rw-r--r-- | sx-question-mode.el | 150 |
1 files changed, 124 insertions, 26 deletions
diff --git a/sx-question-mode.el b/sx-question-mode.el index 20d3035..37ff7e7 100644 --- a/sx-question-mode.el +++ b/sx-question-mode.el @@ -24,6 +24,8 @@ ;;; Code: (require 'markdown-mode) +(eval-when-compile + (require 'rx)) (require 'sx) (require 'sx-question) @@ -179,11 +181,14 @@ Second \"%s\" is replaced with the comment." :type 'string :group 'sx-question-mode) +(defcustom sx-question-mode-pretty-links t + "If non-nil, markdown links are displayed in a compact form." + :type 'boolean + :group 'sx-question-mode) + ;;; Printing a question's content ;;;; Functions -;; This is where most of the work is still left to be done! Need to -;; insert more data from QUESTION. (defun sx-question-mode--print-question (question) "Print a buffer describing QUESTION. QUESTION must be a data structure returned by `json-read'." @@ -207,12 +212,12 @@ DATA can represent a question or an answer." ;; Questions have title (propertize .title - 'font-lock-face 'sx-question-mode-title + 'face 'sx-question-mode-title 'sx-question-mode--section 1) ;; Answers don't (propertize sx-question-mode-answer-title - 'font-lock-face 'sx-question-mode-title + 'face 'sx-question-mode-title 'sx-question-mode--section 2))) ;; Sections can be hidden with overlays (sx-question-mode--wrap-in-overlay @@ -220,7 +225,7 @@ DATA can represent a question or an answer." (sx-question-mode--insert-header ;; Author sx-question-mode-header-author - (sx-question-mode--propertized-display-name .owner) + (sx-question-mode--propertize-display-name .owner) 'sx-question-mode-author ;; Date sx-question-mode-header-date @@ -229,7 +234,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--propertized-display-name .last_editor)))) + (sx-question-mode--propertize-display-name .last_editor)))) 'sx-question-mode-date) (when .title ;; Tags @@ -243,7 +248,7 @@ DATA can represent a question or an answer." (sx-question-mode--wrap-in-overlay '(face sx-question-mode-content-face) (insert "\n" - (sx-question-mode--fill-string + (sx-question-mode--fill-and-fontify .body_markdown) (propertize sx-question-mode-separator 'face 'sx-question-mode-header)))) @@ -253,7 +258,7 @@ DATA can represent a question or an answer." "\n" (propertize sx-question-mode-comments-title - 'font-lock-face 'sx-question-mode-title-comments + 'face 'sx-question-mode-title-comments 'sx-question-mode--section 3)) (sx-question-mode--wrap-in-overlay '(sx-question-mode--section-content t) @@ -262,23 +267,11 @@ DATA can represent a question or an answer." '(face sx-question-mode-content-face) (mapc #'sx-question-mode--print-comment .comments)))))) -(defun sx-question-mode--fill-string (text) - "Fill TEXT according to `markdown-mode' and return it." - (with-temp-buffer - (insert text) - (markdown-mode) - (goto-char (point-min)) - ;; ;; Do something here - ;; (while (null (eobp)) - ;; (skip-chars-forward "\r\n[:blank:]") - ;; (markdown-pre-region)) - (buffer-string))) - -(defun sx-question-mode--propertized-display-name (author) +(defun sx-question-mode--propertize-display-name (author) "Return display_name of AUTHOR with `sx-question-mode-author' face." (sx-assoc-let author (propertize .display_name - 'font-lock-face 'sx-question-mode-author))) + 'face 'sx-question-mode-author))) (defun sx-question-mode--print-comment (data) "Print the comment described by alist DATA." @@ -286,11 +279,11 @@ DATA can represent a question or an answer." (insert (format sx-question-mode-comments-format - (sx-question-mode--propertized-display-name .owner) + (sx-question-mode--propertize-display-name .owner) (substring ;; We fill with three spaces at the start, so the comment is ;; slightly indented. - (sx-question-mode--fill-string + (sx-question-mode--fill-and-fontify (concat " " .body_markdown)) ;; Then we remove the spaces from the first line, since we'll ;; add the username there anyway. @@ -317,8 +310,111 @@ HEADER is given `sx-question-mode-header' face, and value is given FACE. \(fn header value face [header value face] [header value face] ...)" (while args (insert - (propertize (pop args) 'font-lock-face 'sx-question-mode-header) - (propertize (pop args) 'font-lock-face (pop args))))) + (propertize (pop args) 'face 'sx-question-mode-header) + (propertize (pop args) 'face (pop args))))) + + +;;;;; Font-locking the content +(defvar sx-question-mode-bullet-appearance + (propertize (if (char-displayable-p ?•) " •" " *") + 'face 'markdown-list-face) + "String to be displayed as the bullet of markdown list items.") + +(defun sx-question-mode--fill-and-fontify (text) + "Fill TEXT according to `markdown-mode' and return it." + (with-temp-buffer + (erase-buffer) + (insert text) + (markdown-mode) + (font-lock-mode -1) + (when sx-question-mode-bullet-appearance + (font-lock-add-keywords ;; Bullet items. + nil + `(("^ *\\(\\*\\|\\+\\|-\\|\\) " + 1 '(face nil display ,sx-question-mode-bullet-appearance) prepend)))) + (font-lock-add-keywords ;; Highlight usernames. + nil + `(("\\(?: \\|^\\)\\(@\\(?:\\sw\\|\\s_\\)+\\)\\_>" + 1 font-lock-builtin-face))) + ;; Everything. + (font-lock-fontify-region (point-min) (point-max)) + ;; Compact links. + (sx-question-mode--process-links-in-buffer) + ;; And now the filling + (goto-char (point-min)) + (while (null (eobp)) + ;; Don't fill pre blocks. + (unless (sx-question-mode--move-over-pre) + (skip-chars-forward "\r\n[:blank:]") + (fill-paragraph) + (forward-paragraph))) + (buffer-string))) + +(defvar sx-question-mode--link-regexp + ;; Done at compile time. + (rx "[" (group-n 1 (1+ (not (any "]")))) "]" + (or (and "(" (group-n 2 (1+ (not (any ")")))) ")") + (and "[" (group-n 3 (1+ (not (any "]")))) "]"))) + "Regexp matching markdown links.") + +(defun sx-question-mode--process-links-in-buffer () + "Turn all markdown links in this buffer into compact format." + (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) + (sx-question-mode-find-reference + (match-string-no-properties 3) + text)))) + (replace-match + (sx-question-mode--propertize-link + (if sx-question-mode-pretty-links + text + (match-string-no-properties 0)) + url) + :fixedcase :literal nil 0))))) + +(defun sx-question-mode--propertize-link (text url) + "Return a link propertized version of string TEXT. +URL is used as help-echo and as " + (propertize + text + 'face 'link + 'help-echo url + 'url url + 'follow-link t + 'mouse-face 'highlight + 'action #'sx-question-mode-follow-link + 'point-entered + (lambda (&rest _) + (message "%s%s" (propertize "URL: " 'face 'minibuffer-prompt) url)))) + +(defun sx-question-mode-follow-link (&optional pos) + "Follow link at POS or point" + (interactive) + (browse-url + (or (get-text-property (or pos (point)) 'url) + (error "No url under point: %s" (or pos (point)))))) + +(defun sx-question-mode-find-reference (id &optional id2) + "Find url identified by reference ID in current buffer. +If ID is nil, use ID2 instead." + (save-excursion + (save-match-data + (goto-char (point-min)) + (when (search-forward-regexp + (format "^\\s-*\\[\\(%s\\)]:\\s-+\\(?2:[^ ]+\\)" + (or id id2)) + nil t) + (match-string-no-properties 2))))) + +(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)))) ;;; Movement commands @@ -400,6 +496,8 @@ If DIRECTION is negative, move backwards instead." Letters do not insert themselves; instead, they are commands. \\<sx-question-mode> \\{sx-question-mode}" + ;; We call font-lock-region manually. See `sx-question-mode--fill-and-fontify' + (font-lock-mode -1) (remove-hook 'after-change-functions 'markdown-check-change-for-wiki-link t) (remove-hook 'window-configuration-change-hook 'markdown-fontify-buffer-wiki-links t) |