src/interface-utils.lisp

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