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
7 #:comment-thread-to-html
12 (in-package #:lw2.comment-threads
)
14 (named-readtables:in-readtable html-reader
)
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
)))
20 (if-let (id (cdr (assoc :--id c
)))
21 (setf (gethash id existing-comment-hash
) t
)))
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
)))
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
))))
45 (defparameter *comment-parent-hash-cache
* (make-hash-table :test
'eq
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
))))
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>"))
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~}\">"
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")))
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>")))))
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
)))
77 (comment-thread-to-html out-stream
79 (loop for c in comments do
80 (comment-item-to-html out-stream c
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>"
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
)))))))))
90 (defun sort-items (items sort-by
)
91 (multiple-value-bind (sort-fn key-fn
)
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
)))
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
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
)))))))
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 ()
114 (comment-thread-to-html out-stream
116 (comment-item-to-html
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
)
124 :level-invert preview
))))))
126 (progn #|
<div class
="comments-empty-message">(safe (pretty-number (length comments
) id
))</div
>|
#
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
>)))))
136 (output-comments-inner)
137 (progn (format out-stream
"<div id=\"~As\" class=\"comments~:[~; replies-open~]\">" id
(and *enable-voting
* replies-open
))
139 <script
>initializeCommentControls\
(\
)</script
>)
140 (output-comments-inner)
141 (format out-stream
"</div>")))))