src/comment-threads.lisp

   1 (uiop:define-package #:lw2.comment-threads
   2     (:use #:cl #:lw2.utils #:lw2.context #:lw2.user-context #:lw2.conditions #:lw2.html-reader #:lw2.data-viewers.comment)
   3   (:import-from #:alexandria #:if-let)
   4   (:export #:make-comment-parent-hash
   5            #:comment-chrono-to-html
   6            #:comment-item-to-html
   7            #:comment-thread-to-html
   8            #:comment-tree-to-html
   9            #:output-comments
  10            #:sort-items))
  11
  12 (in-package #:lw2.comment-threads)
  13
  14 (named-readtables:in-readtable html-reader)
  15
  16 (defun make-comment-parent-hash-real (comments)
  17   (let ((existing-comment-hash (make-hash-table :test 'equal))
  18         (hash (make-hash-table :test 'equal)))
  19     (dolist (c comments)
  20       (if-let (id (cdr (assoc :--id c)))
  21               (setf (gethash id existing-comment-hash) t)))
  22     (dolist (c comments)
  23       (let* ((parent-id (cdr (assoc :parent-comment-id c)))
  24              (old (gethash parent-id hash)))
  25         (setf (gethash parent-id hash) (cons c old))
  26         (when (and parent-id (not (gethash parent-id existing-comment-hash)))
  27           (let ((placeholder (alist :--id parent-id :parent-comment-id nil :deleted t)))
  28             (setf (gethash parent-id existing-comment-hash) t
  29                   (gethash nil hash) (cons placeholder (gethash nil hash)))))))
  30     (maphash (lambda (k old)
  31                (setf (gethash k hash) (nreverse old)))
  32              hash)
  33     (labels
  34       ((count-children (parent)
  35         (let ((children (gethash (cdr (assoc :--id parent)) hash)))
  36           (+ (length children) (apply #'+ (map 'list #'count-children children)))))
  37        (add-child-counts (comment-list)
  38         (loop for c in comment-list
  39               as id = (cdr (assoc :--id c))
  40               do (setf (gethash id hash) (add-child-counts (gethash id hash)))
  41               collecting (cons (cons :child-count (count-children c)) c))))
  42       (setf (gethash nil hash) (add-child-counts (gethash nil hash))))
  43     hash))
  44
  45 (defparameter *comment-parent-hash-cache* (make-hash-table :test 'eq
  46                                                            :weakness :value
  47                                                            :synchronized t))
  48
  49 (defun make-comment-parent-hash (comments)
  50   (or (gethash comments *comment-parent-hash-cache*)
  51       (setf (gethash comments *comment-parent-hash-cache*) (make-comment-parent-hash-real comments))))
  52
  53 (defun comment-thread-to-html (out-stream emit-comment-item-fn)
  54   (format out-stream "<ul class=\"comment-thread\">")
  55   (funcall emit-comment-item-fn)
  56   (format out-stream "</ul>"))
  57
  58 (defun comment-item-to-html (out-stream comment &key extra-html-fn with-post-title level level-invert)
  59   (with-error-html-block ()
  60     (let ((c-id (cdr (assoc :--id comment)))
  61           (user-id (cdr (assoc :user-id comment))))
  62       (format out-stream "<li id=\"comment-~A\" class=\"comment-item~{ ~A~}\">"
  63               c-id
  64               (list-cond
  65                (t (if (let ((is-odd (or (not level) (evenp level)))) ;inverted because level counts from 0
  66                         (if level-invert (not is-odd) is-odd))
  67                       "depth-odd" "depth-even"))
  68                ((and *current-ignore-hash* (gethash user-id *current-ignore-hash*)) "ignored")))
  69       (unwind-protect
  70         (comment-to-html out-stream comment :with-post-title with-post-title)
  71         (if extra-html-fn (funcall extra-html-fn c-id))
  72         (format out-stream "</li>")))))
  73
  74 (defun comment-tree-to-html (out-stream comment-hash &key (target nil) (level (if target 1 0)) level-invert)
  75   (let ((comments (gethash target comment-hash)))
  76     (when comments
  77       (comment-thread-to-html out-stream
  78         (lambda ()
  79           (loop for c in comments do
  80                (comment-item-to-html out-stream c
  81                  :level level
  82                  :level-invert level-invert
  83                  :extra-html-fn (lambda (c-id)
  84                                   (if (and (= level 10) (gethash c-id comment-hash))
  85                                       (format out-stream "<input type=\"checkbox\" id=\"expand-~A\"><label for=\"expand-~:*~A\" data-child-count=\"~A comment~:P\">Expand this thread</label>"
  86                                               c-id
  87                                               (cdr (assoc :child-count c))))
  88                                   (comment-tree-to-html out-stream comment-hash :target c-id :level (1+ level) :level-invert level-invert)))))))))
  89
  90 (defun sort-items (items sort-by)
  91   (multiple-value-bind (sort-fn key-fn)
  92       (ecase sort-by
  93         ((:old :new) (values (if (eq sort-by :old)
  94                                  (lambda (a b) (ignore-errors (local-time:timestamp< a b)))
  95                                  (lambda (a b) (ignore-errors (local-time:timestamp> a b))))
  96                              (lambda (c) (ignore-errors (local-time:parse-timestring (or (cdr (assoc :posted-at c))
  97                                                                                          (cdr (assoc :created-at c)))))))))
  98     (sort items sort-fn :key key-fn)))
  99
 100 (defun comment-chrono-to-html (out-stream comments)
 101   (let ((comment-hash (make-comment-parent-hash comments))
 102         (comments (sort-items comments :old)))
 103     (comment-thread-to-html out-stream
 104       (lambda ()
 105         (loop for c in comments do
 106               (let* ((c-id (cdr (assoc :--id c)))
 107                      (new-c (acons :children (gethash c-id comment-hash) c)))
 108                 (comment-item-to-html out-stream new-c)))))))
 109
 110 (defun output-comments (out-stream id comments target &key overcomingbias-sort preview chrono replies-open)
 111   (labels ((output-comments-inner ()
 112              (with-error-html-block ()
 113                (if target
 114                    (comment-thread-to-html out-stream
 115                                            (lambda ()
 116                                              (comment-item-to-html
 117                                               out-stream
 118                                               target
 119                                               :level-invert preview
 120                                               :extra-html-fn (lambda (c-id)
 121                                                                (let ((*comment-individual-link* nil))
 122                                                                  (comment-tree-to-html out-stream (make-comment-parent-hash comments)
 123                                                                                        :target c-id
 124                                                                                        :level-invert preview))))))
 125                    (if comments
 126                        (progn #|<div class="comments-empty-message">(safe (pretty-number (length comments) id))</div>|#
 127                          (if chrono
 128                              (comment-chrono-to-html out-stream comments)
 129                              (let ((parent-hash (make-comment-parent-hash comments)))
 130                                (when overcomingbias-sort
 131                                  (setf (gethash nil parent-hash)
 132                                        (sort-items (gethash nil parent-hash) :old)))
 133                                (comment-tree-to-html out-stream parent-hash))))
 134                        <div class="comments-empty-message">("No ~As." id)</div>)))))
 135     (if preview
 136         (output-comments-inner)
 137         (progn (format out-stream "<div id=\"~As\" class=\"comments~:[~; replies-open~]\">" id (and *enable-voting* replies-open))
 138                (unless target
 139                  <script>initializeCommentControls\(\)</script>)
 140                (output-comments-inner)
 141                (format out-stream "</div>")))))