diff options
| -rw-r--r-- | sx-question-mode.el | 2 | ||||
| -rw-r--r-- | sx-question-print.el | 237 | ||||
| -rw-r--r-- | sx-request.el | 57 | ||||
| -rw-r--r-- | sx-user.el | 2 | ||||
| -rw-r--r-- | test/test-printing.el | 6 |
5 files changed, 176 insertions, 128 deletions
diff --git a/sx-question-mode.el b/sx-question-mode.el index 2e06de6..561ae23 100644 --- a/sx-question-mode.el +++ b/sx-question-mode.el @@ -245,7 +245,7 @@ on the current buffer use (set-window-parameter nil 'quit-restore `(other window nil ,(current-buffer)))) - ;; We call font-lock-region manually. See `sx-question-mode--fill-and-fontify' + ;; We call font-lock-region manually. See `sx-question-mode--insert-markdown'. (font-lock-mode -1) (remove-hook 'after-change-functions 'markdown-check-change-for-wiki-link t) (remove-hook 'window-configuration-change-hook diff --git a/sx-question-print.el b/sx-question-print.el index 69a5090..d50eb94 100644 --- a/sx-question-print.el +++ b/sx-question-print.el @@ -281,12 +281,12 @@ DATA can represent a question or an answer." (insert-text-button ;; Questions have title, Answers don't (cond (.title) - ((eq .is_accepted t) sx-question-mode-answer-accepted-title) + (.is_accepted sx-question-mode-answer-accepted-title) (t sx-question-mode-answer-title)) ;; Section level 'sx-question-mode--section (if .title 1 2) 'sx-button-copy .share_link - 'face (if (eq .is_accepted t) 'sx-question-mode-accepted + 'face (if .is_accepted 'sx-question-mode-accepted 'sx-question-mode-title) :type 'sx-question-mode-title) @@ -316,9 +316,9 @@ DATA can represent a question or an answer." (sx-question-mode--insert-header sx-question-mode-header-score (format "%s%s" .score - (cond ((eq .upvoted t) "↑") ((eq .downvoted t) "↓") (t ""))) - (cond ((eq .upvoted t) 'sx-question-mode-score-upvoted) - ((eq .downvoted t) 'sx-question-mode-score-downvoted) + (cond (.upvoted "↑") (.downvoted "↓") (t ""))) + (cond (.upvoted 'sx-question-mode-score-upvoted) + (.downvoted 'sx-question-mode-score-downvoted) (t 'sx-question-mode-score))) ;; Tags @@ -334,10 +334,9 @@ DATA can represent a question or an answer." 'face 'sx-question-mode-header)) (sx--wrap-in-overlay '(face sx-question-mode-content-face) + (insert "\n") + (sx-question-mode--insert-markdown .body_markdown) (insert "\n" - (sx-question-mode--fill-and-fontify - .body_markdown) - "\n" (propertize sx-question-mode-separator 'face 'sx-question-mode-header))) ;; Clean up commments manually deleted. The `append' call is @@ -381,16 +380,19 @@ The comment is indented, filled, and then printed according to (sx-assoc-let comment-data (when (and (numberp .score) (> .score 0)) (insert (number-to-string .score) - (if (eq .upvoted t) "^" "") + (if .upvoted "^" "") " ")) (insert (format sx-question-mode-comments-format (sx-user--format "%d" .owner) (substring - (sx-question-mode--fill-and-fontify - ;; We fill with three spaces at the start, so the comment is - ;; slightly indented. - (concat " " (sx--squash-whitespace .body_markdown))) + ;; We use temp buffer, so that image overlays don't get + ;; inserted with the comment. + (with-temp-buffer + ;; We fill with three spaces at the start, so the comment is + ;; slightly indented. + (sx-question-mode--insert-markdown (concat " " (sx--squash-whitespace .body_markdown))) + (buffer-string)) ;; Then we remove the spaces from the first line, since we'll ;; add the username there anyway. 3)))))) @@ -437,42 +439,60 @@ E.g.: (>= 2 (any lower numeric "/._%&#?=;")))))) "Regexp matching markdown links.") -(defun sx-question-mode--fill-and-fontify (text) - "Return TEXT filled according to `markdown-mode'." - (with-temp-buffer - (insert text) - (delay-mode-hooks (markdown-mode)) - (font-lock-mode -1) - (when sx-question-mode-bullet-appearance - (font-lock-add-keywords ;; Bullet items. - nil - `((,(rx line-start (0+ blank) (group-n 1 (any "*+-")) blank) - 1 '(face nil display ,sx-question-mode-bullet-appearance) prepend)))) - (font-lock-add-keywords ;; Highlight usernames. - nil - `((,(rx (or blank line-start) - (group-n 1 (and "@" (1+ (not space)))) - symbol-end) - 1 font-lock-builtin-face))) - ;; Fontify. - (font-lock-fontify-region (point-min) (point-max)) - ;; And now the content handling: - (goto-char (point-min)) - ;; Handle one paragraph at a time. - (while (null (eobp)) - ;; Some things are not paragraphs, and shouldn't be filled. - (unless (sx-question-mode--dont-fill-here) - (let ((beg (point))) - (skip-chars-forward "\r\n[:blank:]") - (forward-paragraph) - (let ((end (point-marker))) - ;; Compact links. - (sx-question-mode--process-html-tags beg end) - ;; Compact links. - (sx-question-mode--process-links beg end) - (goto-char end)) - (fill-region beg (point))))) - (replace-regexp-in-string "[[:blank:]]+\\'" "" (buffer-string)))) +(defun sx-question-mode--process-markdown-in-region (beg end) + "Process Markdown text between BEG and END. +This does not do Markdown font-locking. Instead, it fills text, +propertizes links, inserts images, cleans up html comments, and +font-locks code-blocks according to mode." + ;; Paragraph filling + (let ((paragraph-start + "\f\\|[ \t]*$\\|[ \t]*[*+-] \\|[ \t]*[0-9]+\\.[ \t]\\|[ \t]*: ") + (paragraph-separate "\\(?:[ \t\f]*\\|.* \\)$") + (adaptive-fill-first-line-regexp "\\`[ \t]*>[ \t]*?\\'") + (adaptive-fill-function #'markdown-adaptive-fill-function)) + (save-restriction + (save-excursion + (narrow-to-region beg end) + ;; Compact links. + (sx-question-mode--process-links-in-buffer) + (sx-question-mode--process-html-tags (point-min) (point-max)) + ;; And now the filling and other handlings. + (goto-char (point-min)) + (while (null (eobp)) + ;; Don't fill pre blocks. + (unless (sx-question-mode--dont-fill-here) + (let ((beg (point))) + (skip-chars-forward "\r\n[:blank:]") + (forward-paragraph) + (fill-region beg (point))))))))) + +(defun sx-question-mode--insert-markdown (text) + "Return TEXT fontified according to `markdown-mode'." + (let ((beg (point))) + (insert + ;; Font-locking needs to be done in a temp buffer, because it + ;; affects the entire buffer even if we narrow. + (with-temp-buffer + (insert text) + (delay-mode-hooks (markdown-mode)) + (font-lock-mode -1) + (when sx-question-mode-bullet-appearance + (font-lock-add-keywords ;; Bullet items. + nil + `((,(rx line-start (0+ blank) (group-n 1 (any "*+-")) blank) + 1 '(face nil display ,sx-question-mode-bullet-appearance) prepend)))) + (font-lock-add-keywords ;; Highlight usernames. + nil + `((,(rx (or blank line-start) + (group-n 1 (and "@" (1+ (not space)))) + symbol-end) + 1 font-lock-builtin-face))) + ;; Everything. + (font-lock-fontify-region (point-min) (point-max)) + (replace-regexp-in-string "[[:blank:]]+\\'" "" (buffer-string)))) + ;; This part can and should be done in place, this way it can + ;; create overlays. + (sx-question-mode--process-markdown-in-region beg (point)))) ;;; HTML tags @@ -516,49 +536,59 @@ END should be a marker." ;;; Handling links -(defun sx-question-mode--process-links (beg end) +(defun sx-question-mode--process-links-in-buffer () "Turn all markdown links between BEG and ENG into compact format. END must be a marker. Image links are downloaded and displayed, if `sx-question-mode-use-images' is non-nil." - (goto-char beg) - (while (search-forward-regexp sx-question-mode--link-regexp end t) - ;; 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 - (if (and sx-question-mode-use-images (eq ?! (elt full-text 0))) - ;; Is it an image? - (sx-question-mode--create-image url) - ;; Or a regular link - (or (if sx-question-mode-pretty-links text full-text) url)) - url))))))) - -(defun sx-question-mode--create-image (url) - "Get and create an image from URL. + (save-excursion + (goto-char (point-min)) + (while (search-forward-regexp sx-question-mode--link-regexp nil t) + ;; 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)) + (image-p (and sx-question-mode-use-images + (eq ?! (elt full-text 0))))) + (when (stringp url) + (replace-match "") + (sx-question-mode--insert-link + (unless image-p + (or (if sx-question-mode-pretty-links text full-text) + url)) + url) + (when image-p + (sx-question-mode--create-image url (- (point) 2)))))))))) + +(defun sx-question-mode--create-image (url point) + "Get and create an image from URL and insert it at POINT. +The image will take the place of the character at POINT. Its size is bound by `sx-question-mode-image-max-width' and `window-body-width'." - (let* ((image - (create-image (sx-request-get-url url) 'imagemagick t)) - (image-width (car (image-size image 'pixels)))) - (append image - (list :width (min sx-question-mode-image-max-width - (window-body-width nil 'pixel) - image-width))))) - -(defun sx-question-mode--insert-link (text-or-image url) + (let* ((ov (make-overlay point (1+ point) (current-buffer) t nil)) + (callback + (lambda (data) + (let* ((image (create-image data 'imagemagick t)) + (image-width (car (image-size image 'pixels)))) + (overlay-put + ov 'display + (append image + (list :width (min sx-question-mode-image-max-width + (window-body-width nil 'pixel) + image-width)))))))) + (sx-request-get-url url callback) + (overlay-put ov 'face 'default))) + +(defun sx-question-mode--insert-link (text url) "Return a link propertized version of TEXT-OR-IMAGE. URL is used as 'help-echo and 'url properties." ;; For now, the only way to handle nested links is to remove them. @@ -569,26 +599,21 @@ URL is used as 'help-echo and 'url properties." (replace-match "") (forward-char 1) (delete-char 1))) - (let ((imagep (not (stringp text-or-image)))) - ;; Images need to be at the start of a line. - (when (and imagep (not (looking-at-p "^"))) - (insert "\n")) - (apply #'insert-text-button - (if imagep " " text-or-image) - ;; Mouse-over - 'help-echo - (format sx-button--link-help-echo - (propertize (sx--shorten-url url) - 'face 'font-lock-function-name-face)) - ;; For visiting and stuff. - 'sx-button-url url - 'sx-button-copy url - :type 'sx-button-link - ;; The last argument of `apply' is a list. - (when imagep - `(face default display ,text-or-image))) - ;; Images need to be at the end of a line too. - (insert "\n"))) + ;; Images need to be at the start of a line. + (unless (or text (looking-at-p "^")) + (insert "\n")) + (insert-text-button (or text " ") + ;; Mouse-over + 'help-echo + (format sx-button--link-help-echo + (propertize (sx--shorten-url url) + 'face 'font-lock-function-name-face)) + ;; For visiting and stuff. + 'sx-button-url url + 'sx-button-copy url + :type 'sx-button-link) + ;; Images need to be at the end of a line too. + (unless text (insert "\n"))) (defun sx-question-mode-find-reference (id &optional fallback-id) "Find url identified by reference ID in current buffer. diff --git a/sx-request.el b/sx-request.el index d7fd058..1eabc41 100644 --- a/sx-request.el +++ b/sx-request.el @@ -190,7 +190,9 @@ the main content of the response is returned." ;; @TODO should use `condition-case' here -- set ;; RESPONSE to 'corrupt or something (response (with-demoted-errors "`json' error: %S" - (json-read-from-string data)))) + (let ((json-false nil) + (json-null :null)) + (json-read-from-string data))))) (kill-buffer response-buffer) (when (and (not response) (string-equal data "{}")) (sx-message "Unable to parse response: %S" response) @@ -199,13 +201,13 @@ the main content of the response is returned." (sx-assoc-let response (when .error_id (error "Request failed: (%s) [%i %s] %S" - .method .error_id .error_name .error_message)) + .method .error_id .error_name .error_message)) (when (< (setq sx-request-remaining-api-requests .quota_remaining) sx-request-remaining-api-requests-message-threshold) (sx-message "%d API requests remaining" sx-request-remaining-api-requests)) (funcall (or process-function #'sx-request-response-get-items) - response))))))) + response))))))) (defun sx-request-fallback (_method &optional _args _request-method _process-function) "Fallback method when authentication is not available. @@ -221,25 +223,44 @@ Currently returns nil." "https://raw.githubusercontent.com/vermiculus/sx.el/data/data/%s.el" "Url of the \"data\" directory inside the SX `data' branch.") -(defun sx-request-get-url (url) - "Fetch and return data stored online at URL." +(defun sx-request--read-buffer-data () + "Return the buffer contents after any url headers. +Error if url headers are absent or if they indicate something +went wrong." + (goto-char (point-min)) + (unless (string-match "200" (thing-at-point 'line)) + (error "Page not found.")) + (if (not (search-forward "\n\n" nil t)) + (error "Headers missing; response corrupt") + (prog1 (buffer-substring (point) (point-max)) + (kill-buffer (current-buffer))))) + +(defun sx-request-get-url (url &optional callback) + "Fetch and return data stored online at URL. +If CALLBACK is nil, fetching is done synchronously and the +data (buffer contents sans headers) is returned as a string. + +Otherwise CALLBACK must be a function of a single argument. Then +`url-retrieve' is called asynchronously and CALLBACK is passed +the retrieved data." (let* ((url-automatic-caching t) (url-inhibit-uncompression t) (url-request-method "GET") (url-request-extra-headers '(("Content-Type" . "application/x-www-form-urlencoded"))) - (response-buffer (url-retrieve-synchronously url))) - (if (not response-buffer) - (error "Something went wrong in `url-retrieve-synchronously'") - (with-current-buffer response-buffer - (progn - (goto-char (point-min)) - (unless (string-match "200" (thing-at-point 'line)) - (error "Page not found.")) - (if (not (search-forward "\n\n" nil t)) - (error "Headers missing; response corrupt") - (prog1 (buffer-substring (point) (point-max)) - (kill-buffer (current-buffer))))))))) + (callback-internal + (when callback + ;; @TODO: Error check in STATUS. + (lambda (_status) + (funcall callback (sx-request--read-buffer-data))))) + (response-buffer + (if callback (url-retrieve url callback-internal nil 'silent) + (url-retrieve-synchronously url)))) + (unless callback + (if (not response-buffer) + (error "Something went wrong in `url-retrieve-synchronously'") + (with-current-buffer response-buffer + (sx-request--read-buffer-data)))))) (defun sx-request-get-data (file) "Fetch and return data stored online by SX. @@ -289,7 +310,7 @@ false, use the symbol `false'. Each element is processed with (defun sx-request-all-stop-when-no-more (response) (or (not response) - (equal :json-false (cdr (assoc 'has_more response))))) + (not (cdr (assoc 'has_more response))))) (provide 'sx-request) ;;; sx-request.el ends here @@ -41,7 +41,7 @@ (creation_date . -1) (display_name . "(unknown user)") (down_vote_count . -1) - (is_employee . :json-false) + (is_employee . nil) (last_access_date . -1) (last_modified_date . -1) (link . "") diff --git a/test/test-printing.el b/test/test-printing.el index 8016444..850edd8 100644 --- a/test/test-printing.el +++ b/test/test-printing.el @@ -167,8 +167,9 @@ after being run through `sx-tag--format'." "Check complicated questions are filled correctly." (should (equal - (sx-question-mode--fill-and-fontify - "Creating an account on a new site requires you to log into that site using *the same credentials you used on existing sites.* For instance, if you used the Stack Exchange login method, you'd... + (with-temp-buffer + (sx-question-mode--insert-markdown + "Creating an account on a new site requires you to log into that site using *the same credentials you used on existing sites.* For instance, if you used the Stack Exchange login method, you'd... 1. Click the \"Log in using Stack Exchange\" button: @@ -192,6 +193,7 @@ after being run through `sx-tag--format'." [1]: http://i.stack.imgur.com/ktFTs.png [2]: http://i.stack.imgur.com/5l2AY.png [3]: http://i.stack.imgur.com/22myl.png") + (buffer-string)) "Creating an account on a new site requires you to log into that site using *the same credentials you used on existing sites.* For instance, if you used the Stack Exchange login method, you'd... |