(defpackage clash/format
  (:documentation "Formatters for trashinfos and trash directories.")
  (:import-from #:cl-xdg-trash/mountpoints
                #:file-or-dir-namestring)
  (:import-from #:cl-xdg-trash/directorysizes
                #:trashed-file-size)
  (:import-from #:cl-xdg-trash/trashinfo
                #:trashinfo-trash-directory
                #:trashinfo-name
                #:trashinfo-deletion-date
                #:trashinfo-original-path
                #:trashinfo-info-file
                #:trashinfo-trashed-file)
  (:use #:cl)
  (:export #:trashinfo-size
           #:format-size
           #:parse-format-string
           #:option-format-string
           #:option-format-string-directives
           #:format-object
           #:format-list
           #:print-format-info
           #:*trashinfo-formatters*
           #:*directory-formatters*
           #:print-clash-format-info
           #:*missing-file-formatters*
           #:*format-switch-base-two-base-ten*))

(in-package :clash/format)

(defvar *trashinfo-size-cache* (make-hash-table :test #'eq)
  "Cache for trashinfo sizes.")

(defun trashinfo-size (trashinfo)
  "Return the size of TRASHINFO and cache it."
  (let ((res (gethash trashinfo *trashinfo-size-cache* :none)))
    (if (eq res :none)
        (setf (gethash trashinfo *trashinfo-size-cache*)
              (trashed-file-size (trashinfo-trash-directory trashinfo)
                                 (trashinfo-name trashinfo)))
        res)))

(defun format-size (count &optional base-two (places 2))
  "Pretty print COUNT, which is a number of bytes. This will append metric
suffixes as necessary. If BASE-TWO is non-nil, use MiB, GiB, etc. suffixes
instead."
  (if (not count)
      "N/A" ;; if finding the size failed
      (let* ((base (if base-two 1024 1000))
             (power (min 10 (floor (if (zerop count) 0 (log count base))))))
        (if (zerop power)
            (format nil "~DB" count)
            (format nil "~,VF~[~:[k~;K~]~:*~;M~;G~;T~;P~;E~;Z~;Y~;R~;Q~]~@[i~]B"
                    places (/ count (expt base power))
                    (1- power) base-two)))))

(defclass format-code ()
  ((name :reader format-code-name
         :type character
         :initarg :name
         :documentation "The character used to invoke this formatter.")
   (action :reader format-code-action
           :type (function (stream t) t)
           :initarg :action
           :documentation "The function to call to use this formatter.")
   (padder :reader format-code-padder
           :type (or null
                     (function (stream (member nil :left :right) string t) t))
           :initarg :padder
           :initform nil
           :documentation
           "An optional function to pad the result of the action.")
   (doc :reader format-code-doc
        :type (or null string)
        :initarg :doc
        :initform nil
        :documentation "The documentation for this format code."))
  (:documentation "A single format escape sequence."))

(defmethod print-object ((obj format-code) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (name padder) obj
      (format stream "%~A~@[ (supports padding)~]" name padder))))

(defun make-format-code (&rest args)
  (apply #'make-instance 'format-code args))

(defun parse-format-string (format-string directives)
  "Parse FORMAT-STRING into a list of string and functions."
  (let ((start 0)
        out end)
    (labels ((ensure-next-char (i thing)
               (unless (< i (1- (length format-string)))
                 (error "Unterminated ~A at char ~A: ~S" thing i format-string)))
             (unknown (i thing)
               (error "Unknown ~A at char ~A: ~S" thing i format-string))
             (push-thing (thing)
               (if (null out)
                   (setq out (list thing)
                         end out)
                   (setf (cdr end) (list thing)
                         end (cdr end))))
             (push-string (str)
               (unless (zerop (length str))
                 (if (stringp (car end))
                     (setf (car end) (format nil "~A~A" (car end) str))
                     (push-thing str)))))
      (do ((i 0 (1+ i)))
          ((>= i (length format-string)))
        (case (aref format-string i)
          (#\%
           (ensure-next-char i "substitution")
           (push-string (subseq format-string start i))
           (let* ((start-i i)
                  (next-c (aref format-string (1+ i)))
                  (pad-type (case next-c (#\< :left) (#\> :right) (t nil))))
             (when pad-type
               (ensure-next-char (1+ i) "substitution")
               (setq next-c (aref format-string (+ i 2)))
               (incf i)
               (incf start))
             (setq start (+ i 2)
                   i (1+ i))
             (case next-c
               (#\% (push-string "%"))
               (#\# (push-thing (if pad-type
                                    (cons :index pad-type)
                                    :index)))
               (t (let ((code (find next-c directives :key #'format-code-name)))
                    (unless (typep code 'format-code)
                      (unknown start-i "substitution"))
                    (unless (or (not pad-type) (format-code-padder code))
                      (error "Format code %~A does not support padding" next-c))
                    (push-thing (if pad-type (cons code pad-type) code)))))))
          (#\\
           (ensure-next-char i "escape sequence")
           (push-string (subseq format-string start i))
           (push-string
            (case (aref format-string (1+ i))
              (#\\ "\\")
              (#\n (string #\Newline))
              (#\t (string #\Tab))
              (#\0 (string #\Nul))
              (t (unknown i "escape sequence"))))
           (setq start (+ i 2)
                 i (1+ i)))))
      (push-string (subseq format-string start))
      out)))

(defclass option-format-string (clingon:option)
  ((directives :accessor option-format-string-directives
               :type list
               :initarg :directives
               :documentation "The format directives to use when parsing.")
   (format-string :accessor option-format-string-format-string
                  :type string
                  :initform ""
                  :documentation "The used-passed format string."))
  (:default-initargs :parameter "FORMAT-CONTROL")
  (:documentation "Option that takes a format string."))

(defmethod clingon:initialize-option ((option option-format-string) &key)
  (setf (option-format-string-format-string option)
        (clingon:option-initial-value option))
  (call-next-method))

(defmethod clingon:derive-option-value ((option option-format-string) arg &key)
  (setf (option-format-string-format-string option) arg))

(defmethod clingon:finalize-option ((option option-format-string) &key)
  (parse-format-string (option-format-string-format-string option)
                       (option-format-string-directives option)))

(defmethod clingon:make-option ((kind (eql :format-string)) &rest args)
  (apply #'make-instance 'option-format-string args))

(defun number-length (n &optional (base 10))
  "Return the number of digits in N when represented in BASE. If N is ngeative,
add one to the result."
  (if (zerop n)
      1
      (+ (floor (log (abs n) base)) (if (minusp n) 2 1))))

(defun format-object (stream control-obj obj
                      &key (index 1) (max-index 1)
                        (max-index-length (number-length max-index))
                        extra-args)
  "Format the object OBJ to STREAM according to CONTROL-OBJECT (which is from
parse-format-string)."
  (dolist (part control-obj)
    (cond
      ((eq :index part)
       (format stream "~A" index))
      ((and (consp part) (eq :index (car part)))
       (case (car part)
         (:left (format stream "~VD" max-index-length index))
         (:right (format stream "~V@<~D~>" max-index-length index))
         (t (format stream "~A" index))))
      ((stringp part)
       (format stream "~A" part))
      ((and (consp part))
       (with-slots (padder action) (car part)
         (funcall padder stream (cdr part)
                  (with-output-to-string (tmp-output)
                    (apply action tmp-output obj extra-args))
                  obj)))
      (t (funcall (format-code-action part) stream obj)))))

(defun format-list (stream control-obj objs
                    &key (indices t) extra-action extra-args)
  "Format a list of objects OBJS with format-object."
  (if (eq t indices)
      (loop with max-index = (length objs)
            with max-index-length = (number-length max-index)
            for obj in objs
            for i upfrom 1
            do (format-object stream control-obj obj
                              :index i :max-index max-index
                              :max-index-length max-index-length
                              :extra-args extra-args)
            when extra-action
              do (funcall extra-action obj))
      (loop with max-index = (reduce #'max indices :initial-value 0)
            with max-index-length = (number-length max-index)
            with objs-arr = (coerce objs 'vector)
            for index in indices
            do (format-object stream control-obj (aref objs-arr index)
                              :index (1+ index) :max-index max-index
                              :max-index-length max-index-length
                              :extra-args extra-args)
            when extra-action
              do (funcall extra-action (aref objs-arr index)))))

(defun print-format-info (stream &rest name-directive-pairs)
  (format stream "~
Format strings use C-style and printf-style escape sequences. Each character
other than one of those with a special meaning noted below is copied to the
output verbatim. The recognized C-style escapes sequences are:
  \"\\0\" - null byte
  \"\\n\" - newline
  \"\\t\" - tab character
  \"\\\\\" - literal backslash~%~%")
  (loop for (name directive . rest) = name-directive-pairs then rest
        for first = t then nil
        while name
        when first
          do (format stream "~
(Sequences with a \"*\" before them support padding by putting a < or > after
the initial % character)~%")
        do (format stream "~
The recognized printf-style sequences for ~A are:
  \"%%\" - a literal %
 *\"%#\" - the index of the current item (used when prompting)~%" name)
        do (dolist (code (sort (copy-list directive) #'char-lessp
                               :key #'format-code-name))
             (with-slots (name doc padder) code
               (format stream " ~:[ ~;*~]\"%~A\"~@[ - ~A~]~%"
                       padder name doc)))
        when rest
          do (terpri stream)))

(defun make-fixed-with-padder (width)
  "Return a padder (for a format-code)"
  (lambda (stream pad-type text obj)
    (declare (ignore obj))
    (case pad-type
      (:left (format stream "~V@<~A~>" width text))
      (:right (format stream "~V<~A~>" width text))
      (t (format stream "~A" text)))))

(defvar *format-switch-base-two-base-ten* nil
  "Switch the base 2 and base 10 for codes.")

(defparameter *trashinfo-formatters*
  (list
   (make-format-code
    :name #\o
    :action (lambda (stream info)
              (format stream "~A" (trashinfo-original-path info :resolve t)))
    :doc "the (o)riginal path (always absolute)")
   (make-format-code
    :name #\O
    :action (lambda (stream info)
              (format stream "~A" (trashinfo-original-path info :normalize t)))
    :doc "the (o)riginal path (possibly relative)")
   (make-format-code
    :name #\n
    :action (lambda (stream info)
              (format stream "~A" (file-or-dir-namestring
                                   (trashinfo-original-path info))))
    :doc "the original (n)ame")
   (make-format-code
    :name #\d
    :action (lambda (stream info)
              (format stream "~A" (trashinfo-trash-directory info)))
    :doc "the trash (d)irectory")
   (make-format-code
    :name #\i
    :action (lambda (stream info)
              (format stream "~A" (trashinfo-info-file info)))
    :doc "the trash(i)nfo file path")
   (make-format-code
    :name #\c
    :action (lambda (stream info)
              (format stream "~A" (trashinfo-trashed-file info)))
    :doc "the (c)urrent (trashed) path")
   (make-format-code
    :name #\u
    :action (lambda (stream info)
              (format stream "~A" (local-time:timestamp-to-unix
                                   (trashinfo-deletion-date info))))
    :doc "the time the file was trashed (in (u)TC seconds)")
   (make-format-code
    :name #\t
    :action (lambda (stream info)
              (local-time:format-timestring
               stream (trashinfo-deletion-date info)
               :format local-time:+asctime-format+))
    :doc "the (t)ime the file was trashed (pretty-printed local time)")
   (make-format-code
    :name #\s
    :action (lambda (stream info)
              (format stream "~A" (trashinfo-size info)))
    :doc "the file's (s)size in bytes")
   (make-format-code
    :name #\h
    :action (lambda (stream info)
              (format stream "~A"
                      (format-size (trashinfo-size info)
                                   *format-switch-base-two-base-ten*)))
    :padder (make-fixed-with-padder 9)
    :doc "the file's size with a (h)uman readable suffix (powers of 10)")
   (make-format-code
    :name #\H
    :action (lambda (stream info)
              (format stream "~A"
                      (format-size (trashinfo-size info)
                                   (not *format-switch-base-two-base-ten*))))
    :padder (make-fixed-with-padder 10)
    :doc "the file's size with a (H)uman readable suffix (power of 2)")))

(defun trashinfo-list-size (infos)
  "Return the sum of the sizes of each trashinfo in INFOS."
  (loop for info in infos
        summing (or (trashinfo-size info) 0)))

(defparameter *directory-formatters*
  (list
   (make-format-code
    :name #\p
    :action (lambda (stream path-and-infos)
              (format stream "~A" (uiop:native-namestring
                                   (uiop:ensure-directory-pathname
                                    (car path-and-infos)))))
    :doc "the directory's (p)ath (with a trailing slash)")
   (make-format-code
    :name #\s
    :action (lambda (stream path-and-infos)
              (format stream "~D" (trashinfo-list-size (cdr path-and-infos))))
    :doc "the directory's (s)ize (in bytes)")
   (make-format-code
    :name #\h
    :action (lambda (stream path-and-infos)
              (format stream "~A" (format-size
                                   (trashinfo-list-size (cdr path-and-infos))
                                   *format-switch-base-two-base-ten*)))
    :padder (make-fixed-with-padder 9)
    :doc "the directory's size with a (h)uman readable suffix (powers of 10)")
   (make-format-code
    :name #\H
    :action (lambda (stream path-and-infos)
              (format stream "~A"
                      (format-size (trashinfo-list-size (cdr path-and-infos))
                                   (not *format-switch-base-two-base-ten*))))
    :padder (make-fixed-with-padder 10)
    :doc "the directory's size with a (H)uman readable suffix (powers of 2)")
   (make-format-code
    :name #\c
    :action (lambda (stream path-and-infos)
              (format stream "~D" (length (cdr path-and-infos))))
    :doc "the (c)ount of files trashed in the directory")
   (make-format-code
    :name #\m
    :action (lambda (stream path-and-infos)
              (let ((infos (cdr path-and-infos)))
                (format stream "~@[s~]" (or (null infos) (cdr infos)))))
    :doc "nothing if only one file was found in this directory, otherwise \"s\"")))

(defun print-clash-format-info (&optional (print-dir t) (stream t))
  "Print format string information for clash to STREAM."
  (apply #'print-format-info
         stream
         "trashed files" *trashinfo-formatters*
         (when print-dir
           (list "trash directories" *directory-formatters*))))