src/interface-utils.lisp

   1 (uiop:define-package #:lw2.interface-utils
   2   (:use #:cl #:lw2.links #:lw2.html-reader)
   3   (:export #:pretty-time #:pretty-time-js #:pretty-time-html
   4            #:pretty-number #:generate-post-auth-link #:clean-lw-link #:votes-to-tooltip #:vote-buttons))
   5
   6 (in-package #:lw2.interface-utils)
   7
   8 (named-readtables:in-readtable html-reader)
   9
  10 (defun pretty-time (timestring &key format loose-parsing)
  11   (let ((time (if loose-parsing
  12                   (chronicity:parse timestring)
  13                   (local-time:parse-timestring timestring))))
  14     (values (local-time:format-timestring nil time :timezone local-time:+utc-zone+ :format (or format '(:day #\  :short-month #\  :year #\  :hour #\: (:min 2) #\  :timezone)))
  15             (* (local-time:timestamp-to-unix time) 1000))))
  16
  17 (defun pretty-time-js ()
  18   "<script async src='data:text/javascript,prettyDate()'></script>")
  19
  20 (defun pretty-time-html (timestring)
  21   (multiple-value-bind (pretty-time js-time) (pretty-time timestring)
  22     (format *html-output* "<span class=\"date hide-until-init\" data-js-date=~A>~A~A</span>"
  23             js-time
  24             pretty-time
  25             (pretty-time-js))))
  26
  27 (defun pretty-number (number &optional object (output-format :html))
  28   (with-output-to-string (*standard-output*)
  29     (when (minusp number)
  30       (write-char #\MINUS_SIGN))
  31     (format t "~:D" (abs number))
  32     (when object
  33       (flet ((write-object () (format t " ~A~P" object number)))
  34         (cond ((eq output-format :html)
  35                (write-string "<span>")
  36                (write-object)
  37                (write-string "</span>"))
  38               (t (write-object)))))))
  39
  40 (defun maybe-need-auth (link need-auth)
  41   (if need-auth
  42       (concatenate 'string link "?need-auth=y")
  43       link))
  44
  45 (define-compiler-macro generate-post-auth-link (post &rest args &key need-auth &allow-other-keys)
  46   `(maybe-need-auth (generate-item-link :post ,post ,@(alexandria:remove-from-plist args :need-auth)) ,need-auth))
  47
  48 (defun generate-post-auth-link (post &rest args &key need-auth &allow-other-keys)
  49   (maybe-need-auth (apply #'generate-item-link :post post :allow-other-keys t args) need-auth))
  50
  51 (defun clean-lw-link (url)
  52   (when url
  53     (ppcre:regex-replace "([^/]*//[^/]*)lesserwrong\.com" url "\\1lesswrong.com")))
  54
  55 (defun votes-to-tooltip (votes)
  56   (if votes
  57       (format nil "~A vote~:*~P"
  58               (typecase votes (integer votes) (list (length votes))))
  59       ""))
  60
  61 (defun vote-buttons (base-score &key (with-buttons t) vote-count post-id af-score as-text extended-score all-votes)
  62   (labels ((button (vote-type)
  63              (when with-buttons
  64                <button type="button" class=("vote ~A" vote-type) data-vote-type=vote-type data-target-type=(if post-id "Posts" "Comments") tabindex="-1" disabled></button>))
  65            (text ()
  66              (if (and af-score (/= af-score 0))
  67                  (format nil "LW: ~A AF: ~A" base-score af-score)
  68                  (pretty-number base-score "point")))
  69            (score-counts ()
  70              (let ((hash (make-hash-table :test 'equal)))
  71                (loop for vote in all-votes
  72                   for agreement = (cdr (assoc :agreement (cdr (assoc :extended-vote-type vote))))
  73                   do (when agreement
  74                        (incf (gethash agreement hash 0))))
  75                hash))
  76            (extended-text (agree-count disagree-count)
  77              (format nil "~D : ~D" agree-count disagree-count))
  78            (extended-tooltip (score-counts agree-count disagree-count)
  79              (format nil "~D agree (~D strongly), ~D disagree (~D strongly); meaningless number: ~D"
  80                      agree-count
  81                      (gethash "bigUpvote" score-counts 0)
  82                      disagree-count
  83                      (gethash "bigDownvote" score-counts 0)
  84                      (cdr (assoc :agreement extended-score))))
  85            (voting (class tooltip text)
  86              <div class=class data-post-id=post-id>
  87                (button "upvote")
  88                <span class="karma-value" title=tooltip>(safe text)</span>
  89                (button "downvote")
  90              </div>))
  91     (when (or base-score extended-score)
  92       (if as-text
  93           (text)
  94           (progn
  95             (when base-score
  96               (voting "karma" (votes-to-tooltip vote-count) (text)))
  97             (when extended-score
  98               (let* ((score-counts (score-counts))
  99                      (agree-count (+ (gethash "smallUpvote" score-counts 0) (gethash "bigUpvote" score-counts 0)))
 100                      (disagree-count (+ (gethash "smallDownvote" score-counts 0) (gethash "bigDownvote" score-counts 0))))
 101                 (voting "agreement"
 102                         (extended-tooltip score-counts agree-count disagree-count)
 103                         (extended-text agree-count disagree-count)))))))))