path: root/sx-question-print.el

;;; sx-question-print.el --- populating the question-mode buffer with content  -*- 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 'markdown-mode)
(require 'sx-button)
(require 'sx)
(require 'sx-question)
(require 'sx-babel)
(require 'sx-user)

(defgroup sx-question-mode nil
  "Customization group for sx-question-mode."
  :prefix "sx-question-mode-"
  :tag "SX Question Mode"
  :group 'sx)

(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
(defface sx-question-mode-header
  '((t :inherit font-lock-variable-name-face))
  "Face used on the question headers in the question buffer."
  :group 'sx-question-mode-faces)

(defface sx-question-mode-title
  '((t :weight bold :inherit default))
  "Face used on the question title in the question buffer."
  :group 'sx-question-mode-faces)

(defface sx-question-mode-title-comments
  '((t :inherit sx-question-mode-title))
  "Face used on the question title in the question buffer."
  :group 'sx-question-mode-faces)

(defcustom sx-question-mode-header-title "\n"
  "String used before the question title at the header."
  :type 'string
  :group 'sx-question-mode)

(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)

(defface sx-question-mode-date
  '((t :inherit font-lock-string-face))
  "Face used on the question date in the question buffer."
  :group 'sx-question-mode-faces)

(defcustom sx-question-mode-header-date "\nPosted on: "
  "String used before the question date at the header."
  :type 'string
  :group 'sx-question-mode)

(defface sx-question-mode-score
  '((t))
  "Face used for the score in the question buffer."
  :group 'sx-question-mode-faces)

(defface sx-question-mode-score-downvoted
  '((t :inherit (font-lock-warning-face sx-question-mode-score)))
  "Face used for downvoted score in the question buffer."
  :group 'sx-question-mode-faces)

(defface sx-question-mode-score-upvoted
  '((t :weight bold
       :inherit (font-lock-function-name-face sx-question-mode-score)))
  "Face used for downvoted score in the question buffer."
  :group 'sx-question-mode-faces)

(defface sx-question-mode-sub-sup
  '((t :height 0.7))
  "Face used on <sub> and <sup> tags."
  :group 'sx-question-mode-faces)

(defcustom sx-question-mode-header-tags "\nTags:      "
  "String used before the question tags at the header."
  :type 'string
  :group 'sx-question-mode)

(defcustom sx-question-mode-header-score "\nScore:     "
  "String used before the question score at the header."
  :type 'string
  :group 'sx-question-mode)

(defface sx-question-mode-content-face
  '((((background dark)) :background "#090909")
    (((background light)) :background "#f4f4f4"))
  "Face used on the question body in the question buffer.
This shouldn't have a foreground, or this will interfere with
font-locking."
  :group 'sx-question-mode-faces)

(defcustom sx-question-mode-last-edit-format " (edited %s ago by %s)"
  "Format used to describe last edit date in the header.
First \"%s\" is replaced with the date and the second \"%s\" with
the editor's name."
  :type 'string
  :group 'sx-question-mode)

(defcustom sx-question-mode-separator
  (concat (make-string 80 ?_) "\n")
  "Separator used between header and body."
  :type 'string
  :group 'sx-question-mode)

(defcustom sx-question-mode-answer-title "Answer"
  "Title used at the start of \"Answer\" sections."
  :type 'string
  :group 'sx-question-mode)

(defface sx-question-mode-accepted
  '((t :foreground "ForestGreen" :inherit sx-question-mode-title))
  "Face used for accepted answers in the question buffer."
  :group 'sx-question-mode-faces)

(defcustom sx-question-mode-answer-accepted-title "Accepted Answer"
  "Title used at the start of accepted \"Answer\" section."
  :type 'string
  :group 'sx-question-mode)

(defcustom sx-question-mode-comments-title " Comments"
  "Title used at the start of \"Comments\" sections."
  :type 'string
  :group 'sx-question-mode)

(defcustom sx-question-mode-comments-format "%s: %s\n"
  "Format used to display comments.
First \"%s\" is replaced with user name.  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)

(defconst sx-question-mode--sort-methods
  (let ((methods
         '(("Higher-scoring" . sx-answer-higher-score-p)
           ("Newer"          . sx-answer-newer-p)
           ("More active"    . sx-answer-more-active-p))))
    (append (mapcar (lambda (x) (cons (concat (car x) " first") (cdr x)))
              methods)
            (mapcar (lambda (x) (cons (concat (car x) " last")
                                 (sx--invert-predicate (cdr x))))
              methods))))

(defcustom sx-question-mode-answer-sort-function
  #'sx-answer-higher-score-p
  "Function used to sort answers in the question buffer."
  :type
  (cons 'choice
        (mapcar (lambda (x) `(const :tag ,(car x) ,(cdr x)))
          sx-question-mode--sort-methods))
  :group 'sx-question-mode)

(defcustom sx-question-mode-use-images
  (eval-when-compile
    (image-type-available-p 'imagemagick))
  "Non-nil if SX should download and display images.
By default, this is `t' if the `imagemagick' image type is
available (checked with `image-type-available-p').  If this image
type is not available, images won't work."
  :type 'boolean
  :group 'sx-question-mode)

(defcustom sx-question-mode-image-max-width 550
  "Maximum width, in pixels, of images in the question buffer."
  :type 'integer
  :group 'sx-question-mode)


;;; Functions
;;;; Printing the general structure
(defun sx-question-mode--print-question (question)
  "Print a buffer describing QUESTION.
QUESTION must be a data structure returned by `json-read'."
  (setq sx-question-mode--data question)
  ;; Clear the overlays
  (mapc #'delete-overlay sx--overlays)
  (setq sx--overlays nil)
  ;; Print everything
  (sx-question-mode--print-section question)
  (sx-assoc-let question
    (mapc #'sx-question-mode--print-section
          (cl-sort .answers sx-question-mode-answer-sort-function)))
  (insert "\n\n                       ")
  (insert-text-button "Write an Answer" :type 'sx-button-answer)
  ;; Go up
  (goto-char (point-min))
  (sx-question-mode-next-section))

(defun sx-question-mode--print-section (data)
  "Print a section corresponding to DATA.
DATA can represent a question or an answer."
  ;; This makes `data' accessible through `sx--data-here'.
  (sx-assoc-let data
    (sx--wrap-in-overlay
        (list 'sx--data-here data)
      (insert sx-question-mode-header-title)
      (insert-text-button
       ;; Questions have title, Answers don't
       (cond (.title)
             ((eq .is_accepted t) 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
               'sx-question-mode-title)
       :type 'sx-question-mode-title)

      ;; 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))

        ;; Date
        (sx-question-mode--insert-header
         sx-question-mode-header-date
         (concat
          (sx-time-seconds-to-date .creation_date)
          (when .last_edit_date
            (format sx-question-mode-last-edit-format
              (sx-time-since .last_edit_date)
              (sx-user--format "%d" .last_editor))))
         'sx-question-mode-date)

        ;; Score and upvoted/downvoted status.
        (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)
               (t 'sx-question-mode-score)))

        ;; Tags
        (when .title
          ;; Tags
          (sx-question-mode--insert-header
           sx-question-mode-header-tags
           (sx-tag--format-tags .tags .site_par)
           nil))
        ;; Body
        (insert "\n"
                (propertize sx-question-mode-separator
                            'face 'sx-question-mode-header))
        (sx--wrap-in-overlay
            '(face sx-question-mode-content-face)
          (insert "\n"
                  (sx-question-mode--fill-and-fontify
                   .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
           '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--print-comment (comment-data)
  "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-overlay
      (list 'sx--data-here comment-data)
    (sx-assoc-let comment-data
      (when (and (numberp .score) (> .score 0))
        (insert (number-to-string .score)
                (if (eq .upvoted t) "^" "")
                " "))
      (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)))
          ;; Then we remove the spaces from the first line, since we'll
          ;; add the username there anyway.
          3))))))

(defun sx-question-mode--insert-header (&rest args)
  "Insert propertized ARGS.
ARGS is a list of repeating values -- `header', `value', and
`face'.  `header' is given `sx-question-mode-header' as a face,
where `value' is given `face' as its face.

\(fn HEADER VALUE FACE [HEADER VALUE FACE] [HEADER VALUE FACE] ...)"
  (while args
    (insert
     (propertize (pop args) 'face 'sx-question-mode-header)
     (let ((header (pop args))
           (face (pop args)))
       (if face (propertize header 'face face)
         header)))))


;;;; Printing and Font-locking the content (body)
(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.")

(defconst sx-question-mode--reference-regexp
  (rx line-start (0+ blank) "[%s]:" (0+ blank)
      (group-n 1 (1+ (not (any blank "\n\r")))))
  "Regexp used to find the url of labeled links.
E.g.:
   [1]: https://...")

(defconst sx-question-mode--link-regexp
  ;; Done at compile time.
  (rx (or (and "[" (optional (group-n 6 "meta-")) "tag:"
               (group-n 5 (+ (not (any " ]")))) "]")
          (and (opt "!") "[" (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") "://") ""
                          (>= 2 (any lower numeric "_%"))
                          "."
                          (>= 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))))


;;; HTML tags
(defconst sx-question-mode--html-tag-regexp
  (rx "<" (group-n 1 "%s") (* (not (any ">"))) ">"))

(defun sx-question-mode--process-html-tags (beg end)
  "Hide all html tags between BEG and END and possibly interpret them.
END should be a marker."
  ;; This code understands nested html, but not if the same tag is
  ;; nested in itself (e.g., <kbd><kbd></kbd></kbd>).
  (goto-char beg)
  (while (search-forward-regexp
          (format sx-question-mode--html-tag-regexp "[[:alpha:]]+")
          end 'noerror)
    (unless (save-match-data (markdown-code-at-point-p))
      (let ((tag (match-string 1))
            (l   (match-beginning 0)))
        (replace-match "")
        (when (search-forward-regexp
               (format sx-question-mode--html-tag-regexp (concat "/" tag))
               ;; Searching for a match has no bounds.
               nil 'noerror)
          (let ((r (copy-marker (match-beginning 0))))
            ;; The code tag is special, because it quotes everything in
            ;; the middle.
            (if (string= tag "quote")
                (progn (replace-match "`")
                       (save-excursion (goto-char l) (insert "`")))
              (replace-match "")
              ;; Handle stuff between the two tags.
              (save-match-data (sx-question-mode--process-html-tags l r))
              (cond
               ((string= tag "kbd")
                (add-text-properties l r '(face markdown-inline-code-face)))
               ((string= tag "sub")
                (add-text-properties
                 l r '(face sx-question-mode-sub-sup display (raise -0.3))))
               ((string= tag "sup")
                (add-text-properties
                 l r '(face sx-question-mode-sub-sup display (raise +0.3))))))))))))


;;; Handling links
(defun sx-question-mode--process-links (beg end)
  "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.
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)
  "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.
  (when (eq (char-before) ?\[)
    (insert "a")
    (forward-char -2)
    (if (looking-at sx-question-mode--link-regexp)
        (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")))

(defun sx-question-mode-find-reference (id &optional fallback-id)
  "Find url identified by reference ID in current buffer.
If ID is nil, use FALLBACK-ID instead."
  (save-excursion
    (save-match-data
      (goto-char (point-min))
      (when (search-forward-regexp
             (format sx-question-mode--reference-regexp
               (or id fallback-id))
             nil t)
        (match-string-no-properties 1)))))


;;; Things we don't fill
(defun sx-question-mode--dont-fill-here ()
  "If text shouldn't be filled here, return t and skip over it."
  (catch 'sx-question-mode-done
    (let ((before (point)))
      (skip-chars-forward "\r\n[:blank:]")
      (let ((first-non-blank (point)))
        (dolist (it '(sx-question-mode--skip-and-fontify-pre
                      sx-question-mode--skip-headline
                      sx-question-mode--skip-references
                      sx-question-mode--skip-comments))
          ;; If something worked, keep point where it is and return t.
          (if (funcall it) (throw 'sx-question-mode-done t)
            ;; Before calling each new function. Go back to the first
            ;; non-blank char.
            (goto-char first-non-blank)))
        ;; If nothing matched, go back to the very beginning.
        (goto-char before)
        ;; And return nil
        nil))))

(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 (line-beginning-position)))
    ;; To identify code-blocks we need to be at start of line.
    (goto-char beg)
    (when (markdown-match-pre-blocks (line-end-position))
      (sx-babel--make-pre-button beg (point))
      t)))

(defun sx-question-mode--skip-comments ()
  "If there's an html comment ahead, skip it and return t."
  ;; @TODO: Handle the comment.
  ;; "Handling means to store any relevant metadata it might be holding."
  (markdown-match-comments (line-end-position)))

(defun sx-question-mode--skip-headline ()
  "If there's a headline ahead, skip it and return non-nil."
  (when (or (looking-at-p "^#+ ")
            (progn (forward-line 1) (looking-at-p "===\\|---")))
    ;; Returns non-nil.
    (forward-line 1)))

(defun sx-question-mode--skip-references ()
  "If there's a reference ahead, skip it and return non-nil."
  (forward-line 0)
  (when (looking-at-p (format sx-question-mode--reference-regexp ".+"))
    ;; Returns non-nil
    (forward-paragraph 1)
    t))

(provide 'sx-question-print)
;;; sx-question-print.el ends here

;; Local Variables:
;; indent-tabs-mode: nil
;; End: