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     (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 ea-agreement-voting)
  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            (extended-text ()
  71              (alist-bind
  72               (agreement agree disagree) extended-score
  73               ;; LW uses agreement, EAF uses agree and disagree
  74                (cond
  75                  (ea-agreement-voting
  76                   (format nil #.(uiop:strcat "~D" #\HAIR_SPACE #\RATIO #\HAIR_SPACE "~D")
  77                           (or agree 0)
  78                           (or disagree 0)))
  79                  ((or agree agreement)
  80                   (pretty-number (or agree agreement 0))))))
  81            (extended-tooltip ()
  82              (alist-bind
  83               (agreement-vote-count agree disagree) extended-score
  84               ;; LW uses agreement-vote-count
  85               (cond
  86                 (ea-agreement-voting
  87                  (format nil "Total points: ~D" (+ (or agree 0) (or disagree 0))))
  88                 (agreement-vote-count
  89                  (votes-to-tooltip (or agreement-vote-count 0))))))
  90            (voting (class tooltip text)
  91              <div class=(safe ("~A voting-controls" class))
  92                   (with-html-stream-output (:stream stream)
  93                     (when post-id (format stream "data-post-id='~A' " post-id))
  94                     (unless (string-equal class "karma")
  95                       (format stream "data-vote-axis='~A' " class)))>
  96                (button "upvote")
  97                <span class="karma-value" title=tooltip>(safe text)</span>
  98                (button "downvote")
  99              </div>))
 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)
 104                                                     (extended-tooltip))))
 105         (progn
 106           (when base-score
 107             (voting "karma" (votes-to-tooltip vote-count) (text)))
 108           (when (or extended-score ea-agreement-voting)
 109             (voting "agreement"
 110                     (extended-tooltip)
 111                     (extended-text)))))))