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 #:alist-bind)
   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     (let* ((url (ppcre:regex-replace "([^/]*//[^/]*)lesserwrong\.com" url "\\1lesswrong.com"))
  55            (url (ppcre:regex-replace "([^/:]*://[^/]*)forum-bots\.effectivealtruism.org" url "\\1forum.effectivealtruism.org")))
  56       url)))
  57
  58 (defun votes-to-tooltip (votes)
  59   (if votes
  60       (format nil "~A vote~:*~P"
  61               (typecase votes (integer votes) (list (length votes))))
  62       ""))
  63
  64 (defun vote-buttons (base-score &key (with-buttons t) vote-count post-id af-score as-text extended-score ea-agreement-voting)
  65   (labels ((button (vote-type)
  66              (when with-buttons
  67                <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>))
  68            (text ()
  69              (if (and af-score (/= af-score 0))
  70                  (format nil "LW: ~A AF: ~A" base-score af-score)
  71                  (pretty-number base-score "point")))
  72            (extended-text ()
  73              (alist-bind
  74               (agreement agree disagree) extended-score
  75               ;; LW uses agreement, EAF uses agree and disagree
  76                (cond
  77                  (ea-agreement-voting
  78                   (format nil #.(uiop:strcat "~D" #\HAIR_SPACE #\RATIO #\HAIR_SPACE "~D")
  79                           (or agree 0)
  80                           (or disagree 0)))
  81                  ((or agree agreement)
  82                   (pretty-number (or agree agreement 0))))))
  83            (extended-tooltip ()
  84              (alist-bind
  85               (agreement-vote-count agree disagree) extended-score
  86               ;; LW uses agreement-vote-count
  87               (cond
  88                 (ea-agreement-voting
  89                  (format nil "Total points: ~D" (+ (or agree 0) (or disagree 0))))
  90                 (agreement-vote-count
  91                  (votes-to-tooltip (or agreement-vote-count 0))))))
  92            (voting (class tooltip text)
  93              <div class=(safe ("~A voting-controls" class))
  94                   (with-html-stream-output (:stream stream)
  95                     (when post-id (format stream "data-post-id='~A' " post-id))
  96                     (unless (string-equal class "karma")
  97                       (format stream "data-vote-axis='~A' " class)))>
  98                (button "upvote")
  99                <span class="karma-value" title=tooltip>(safe text)</span>
 100                (button "downvote")
 101              </div>))
 102     (if as-text
 103         (hash-cond (make-hash-table)
 104                    (base-score :karma (list (text) (votes-to-tooltip vote-count)))
 105                    (extended-score :agreement (list (extended-text)
 106                                                     (extended-tooltip))))
 107         (progn
 108           (when base-score
 109             (voting "karma" (votes-to-tooltip vote-count) (text)))
 110           (when (or extended-score ea-agreement-voting)
 111             (voting "agreement"
 112                     (extended-tooltip)
 113                     (extended-text)))))))