(defpackage clash
  (:documentation "Command line interface to the XDG trashcan.")
  (:import-from #:cl-xdg-trash/trashinfo
                #:trashinfo-original-path
                #:trashinfo-trash-directory
                #:trashinfo-info-file
                #:trashinfo-name
                #:trashinfo-trashed-file
                #:trashinfo-deletion-date)
  (:import-from #:cl-xdg-trash/mountpoints
                #:file-or-dir-namestring
                #:ensure-nonwild-pathname)
  (:import-from #:cl-xdg-trash/directorysizes
                #:trashed-file-size)
  (:use #:cl)
  (:export #:toplevel))

(in-package :clash)

;; remove extra newline at the end of the usage message
(defmethod clingon:print-usage :around (command stream &key)
  (let ((msg (with-output-to-string (str-stream)
               (call-next-method command str-stream))))
    (format stream "~A" (subseq msg 0 (1- (length msg))))))


;; Datetime stuff
(define-condition date-parse-error (error)
  ((source :accessor date-parse-error-source
           :type string
           :initarg :source
           :documentation "The string that failed to parse.")
   (pos :accessor date-parse-error-position
        :type (or null integer)
        :initarg :position
        :initform nil
        :documentation "The position of the error, or nil.")
   (message :accessor date-parse-error-message
            :type string
            :initarg :message
            :documentation "A message describing the error."))
  (:report (lambda (condition stream)
             (with-slots (source pos message) condition
               (format
                stream "Failed to parse date ~S~@[ at position ~A~]: ~A"
                source pos message))))
  (:documentation "A condition representing a failure in parsing a date range."))

(defparameter *month-conversion-table*
  '((1 "january" "jan")
    (2 "february" "feb")
    (3 "march" "mar")
    (4 "april" "apr")
    (5 "may")
    (6 "june" "jun")
    (7 "july" "jly" "jul")
    (8 "august" "aug")
    (9 "september" "sep")
    (10 "october" "oct")
    (11 "november" "nov")
    (12 "december" "dec")))

(defun parse-month-string (str)
  (loop for (num . text) in *month-conversion-table*
        when (member str text :test 'equalp)
          do (return num)))

(defun add-time-registers (source stamp registers)
  (destructuring-bind (hour minute second am-pm) (last registers 4)
    (local-time:adjust-timestamp stamp
      (offset :sec (parse-integer (or second "0")))
      (offset :minute (parse-integer (or minute "0")))
      (offset :hour
              (if (not hour)
                  0
                  (cond
                    ((or (not am-pm) (equalp am-pm "am")) (parse-integer hour))
                    ((equalp am-pm "pm") (+ (parse-integer hour) 12))
                    (t (error 'date-parse-error
                              :source source
                              :message
                              (format nil "excpected \"AM\"/\"PM\", got: ~A"
                                      am-pm)))))))))

(defun current-year ()
  "Return the current year."
  (local-time:timestamp-year (local-time:now)))

(defun local-today ()
  "Return a timestamp representing the midnight today in local-time."
  (local-time:adjust-timestamp! (local-time:now)
    (set :hour 0)
    (set :minute 0)
    (set :sec 0)
    (set :nsec 0)))

(defparameter *date-parse-formats*
  (let ((time-regexp
          (format nil "(?:\\s|$)(?:\\s*([0-9]{1,2}):([0-9]{1,2})~
                       (?::([0-9]{1,2}))?(?:\\s*(AM|PM))?)?"))
        out)
    (flet ((def (regexp func)
             (push (cons (cl-ppcre:create-scanner
                          (format nil "~A~A" regexp time-regexp)
                          :extended-mode t :case-insensitive-mode t
                          :multi-line-mode t)
                         func)
                   out))
           (def-no-time (regexp func)
             (push (cons (cl-ppcre:create-scanner regexp
                                                  :extended-mode t :case-insensitive-mode t
                                                  :multi-line-mode t)
                         func)
                   out)))
      (def-no-time "^$"
          (lambda (source registers)
            (declare (ignore source registers))
            (local-time:now)))
      (def-no-time "[0-9]+"
          (lambda (source registers)
            (declare (ignore registers))
            (local-time:unix-to-timestamp (parse-integer source))))
      (def-no-time "now"
          (lambda (source registers)
            (declare (ignore source registers))
            (local-time:now)))
      (def "today"
          (lambda (source registers)
            (add-time-registers source
                                (local-today)
                                registers)))
      (def "yesterday"
          (lambda (source registers)
            (add-time-registers source
                                (local-time:adjust-timestamp! (local-today)
                                  (offset :day -1))
                                registers)))
      ;; 2025/10/23 3:00 pm
      (def "([0-9]+)(?:\\s+|/)([0-9]{1,2})(?:\\s+|/)([0-9]{1,2})"
          (lambda (source registers)
            (destructuring-bind (year month day &rest ignore) registers
              (declare (ignore ignore))
              (add-time-registers source
                                  (local-time:encode-timestamp
                                   0 0 0 0
                                   (parse-integer day)
                                   (parse-integer month)
                                   (parse-integer year))
                                  registers))))
      ;; Oct 10/23 3:00 PM
      (def "([A-Za-z]+)(?:\\s+|/)([0-9]{1,2})(?:(?:\\s+|/)([0-9]+))?"
          (lambda (source registers)
            (destructuring-bind (month-str day year &rest ignore)
                registers
              (declare (ignore ignore))
              (let ((month (parse-month-string month-str)))
                (unless month
                  (error 'date-parse-error
                         :source source
                         :message (format nil "unknown month: ~S" month-str)))
                (add-time-registers source
                                    (local-time:encode-timestamp
                                     0 0 0 0
                                     (parse-integer day)
                                     month
                                     (if year
                                         (parse-integer year)
                                         (current-year)))
                                    registers))))))))

(defun parse-date-time (string)
  "Parse date and time from STRING."
  (dolist (entry *date-parse-formats*)
    (destructuring-bind (scanner . func) entry
      (multiple-value-bind (start end reg-starts reg-ends)
          (cl-ppcre:scan scanner string)
        (when (and (eql start 0)
                   (eql end (length string)))
          (return-from parse-date-time
            (funcall func
                     string
                     (loop for s across reg-starts
                           for e across reg-ends
                           when (and s e)
                             collect (subseq string s e)
                           else
                             collect nil))))))))

(defun parse-date-range (string)
  "Parse a date range from STRING."
  (let ((sep (search ".." string)))
    (when (not sep)
      (error 'date-parse-error
             :source string
             :message "expected \"..\" to separate start and end date"))
    (let ((second-sep (search ".." string :start2 (1+ sep))))
      (when second-sep
        (error 'date-parse-error :source string
                                 :position second-sep
                                 :message "multiple \"..\" found")))
    (macrolet ((trim (str)
                 `(string-trim '(#\Tab #\Space #\Newline) ,str)))
      (cons (parse-date-time (trim (subseq string 0 sep)))
            (parse-date-time (trim (subseq string (+ sep 2))))))))

(defun timestamp-in-ranges (stamp ranges)
  "Return non-nil if STAMP is in one of RANGES."
  (some (lambda (range)
          (destructuring-bind (start . end) range
            (when (local-time:timestamp> start end)
              (rotatef start end))
            (and (local-time:timestamp>= stamp start)
                 (local-time:timestamp<= stamp end))))
        ranges))

(defclass option-date-range (clingon:option)
  ((ranges :accessor option-date-range-ranges
           :initarg ranges
           :initform nil
           :type list
           :documentation "List of conses of local-time:timestamps representing
date ranges.."))
  (:default-initargs :parameter "RANGE"))

(defmethod clingon:derive-option-value ((option option-date-range) arg &key)
  (push (parse-date-range arg) (option-date-range-ranges option))
  (option-date-range-ranges option))

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


;; Filtering
(defun clingon-filtering-options ()
  "Return some options that can be used by many commands for filtering."
  (list
   (clingon:make-option
    :flag
    :key :print-format-info
    :description "print information about format strings, then exit"
    :long-name "format-info")
   (clingon:make-option
    :flag
    :key :strings
    :description "don't use regexp to match file names"
    :short-name #\s
    :long-name "strings")
   (clingon:make-option
    :flag
    :key :exact
    :description "force exact match"
    :short-name #\e
    :long-name "exact")
   (clingon:make-option
    :flag
    :key :full-path
    :description "match against full file paths"
    :short-name #\p
    :long-name "full-paths")
   (clingon:make-option
    :flag
    :key :case-insensitive
    :description "match case-insensitively"
    :short-name #\i
    :long-name "case-insensitive")
   (clingon:make-option
    :flag
    :key :invert
    :description "invert result"
    :short-name #\v
    :long-name "invert")
   (clingon:make-option
    :string
    :key :format
    :description "format to print results in"
    :short-name #\f
    :long-name "format")
   (clingon:make-option
    :date-range
    :key :date-ranges
    :description "range of dates to consider in search"
    :short-name #\R
    :long-name "date-range")))

(declaim (inline compare-trashinfo-to-string))
(defun compare-trashinfo-to-string (trashinfo filter full-path exact
                                    case-insensitive)
  "Compare TRASHINFO's name or path to FILTER using the provided matching
options."
  (let* ((orig-path (trashinfo-original-path trashinfo))
         (target (if full-path orig-path (file-or-dir-namestring orig-path))))
    (cond
      ((and exact case-insensitive) (equalp target filter))
      (exact (equal target filter))
      (t (search filter target :test (if case-insensitive #'equalp #'eql))))))

(declaim (inline compare-trashinfo-to-scanner))
(defun compare-trashinfo-to-scanner (trashinfo filter full-path exact)
  "Compare TRASHINFO's name or path to FILTER, which is a cl-ppcre scanner."
  (let* ((orig-path (trashinfo-original-path trashinfo))
         (target (if full-path orig-path (file-or-dir-namestring orig-path))))
    (multiple-value-bind (start end) (cl-ppcre:scan filter target)
      (and start
           (or (not exact)
               (and (= start 0) (= end (length target))))))))

(defun filter-trashinfos-by (trashinfos filter &key regexp full-path
                                                 exact case-insensitive
                                                 invert)
  "Filter the list of trashinfo objects TRASHINFOS by FILTER, which is a
string."
  (if regexp
      (let ((scanner (cl-ppcre:create-scanner
                      filter :case-insensitive-mode case-insensitive)))
        (remove-if
         (lambda (info)
           (let ((res (compare-trashinfo-to-scanner info scanner
                                                    full-path exact)))
             (or (and (not invert) (not res))
                 (and invert res))))
         trashinfos))
      (remove-if
       (lambda (info)
         (let ((res (compare-trashinfo-to-string
                     info filter full-path exact case-insensitive)))
           (or (and (not invert) (not res))
               (and invert res))))
       trashinfos)))

(defun list-nonexcluded-trash-dirs (cmd)
  "Return a list of all trash directories, except those excluded by CMD."
  (append (set-difference (cl-xdg-trash:list-trash-directories)
                          (clingon:getopt cmd :ignored-trashes)
                          :test #'uiop:pathname-equal)
          (mapcar #'ensure-nonwild-pathname
                  (clingon:getopt cmd :extra-trashes))))

(defun limit-trashinfo-dates-for-cmd (cmd trashinfos)
  (let ((ranges (clingon:getopt cmd :date-ranges)))
    (if (not ranges)
        trashinfos
        (delete-if (lambda (info)
                     (not (timestamp-in-ranges (trashinfo-deletion-date info)
                                               ranges)))
                   trashinfos))))

(defun list-trashinfos-for-cmd (cmd)
  "List trashinfos for the command CMD."
  (let ((args (clingon:command-arguments cmd)))
    (when (cdr args)
      (clingon:print-usage-and-exit cmd t))
    (limit-trashinfo-dates-for-cmd
     cmd
     (if (not (car args))
         (cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd))
         (let ((filter (car args))
               (strings (clingon:getopt cmd :strings))
               (exact (clingon:getopt cmd :exact))
               (full-path (clingon:getopt cmd :full-path))
               (case-insensitive (clingon:getopt cmd :case-insensitive))
               (invert (clingon:getopt cmd :invert)))
           (filter-trashinfos-by
            (cl-xdg-trash:list-trashed-files
             (list-nonexcluded-trash-dirs cmd))
            filter
            :regexp (not strings)
            :exact exact
            :full-path full-path
            :case-insensitive case-insensitive
            :invert invert))))))


;; Formatting
(defparameter *trashinfo-formatters*
  `((#\# :index
         "the index of the current file (used when prompting for files)")
    (#\o ,(lambda (stream info)
            (format stream "~A" (trashinfo-original-path info)))
         "the (o)riginal path")
    (#\n ,(lambda (stream info)
            (format stream "~A" (file-or-dir-namestring
                                 (trashinfo-original-path info))))
         "the original (n)ame")
    (#\d ,(lambda (stream info)
            (format stream "~A" (trashinfo-trash-directory info)))
         "the trash (d)irectory")
    (#\i ,(lambda (stream info)
            (format stream "~A" (trashinfo-info-file info)))
         "the trash(i)nfo file path")
    (#\c ,(lambda (stream info)
            (format stream "~A" (trashinfo-trashed-file info)))
         "the (c)urrent (trashed) path")
    (#\u ,(lambda (stream info)
            (format stream "~A" (local-time:timestamp-to-unix
                                 (trashinfo-deletion-date info))))
         "the time the file was trashed (in (u)TC seconds)")
    (#\t ,(lambda (stream info)
            (local-time:format-timestring
             stream (trashinfo-deletion-date info)
             :format local-time:+asctime-format+))
         "the (t)ime the file was trashed (pretty-printed local time)")
    (#\t ,(lambda (stream info)
            (format stream "~A" (trashed-file-size
                                 (trashinfo-trash-directory info)
                                 (trashinfo-name info))))
         "the file's (s)size")
    (#\% ,(lambda (stream info)
            (declare (ignore info))
            (format stream "%"))
         "a liternal %")))

(defun process-format-string (format-string)
  "Process 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 ((fun (second (assoc (aref format-string (1+ i))
                                     *trashinfo-formatters*))))
             (unless fun
               (unknown i "substitution"))
             (push-thing fun))
           (setq start (+ i 2)
                 i (1+ i)))
          (#\\
           (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)))

(defun format-trashinfo (stream format-object info &key (index 1))
  "Format the trashinfo INFO to STREAM accoring to FORMAT-OBJECT (which is from
process-format-string)."
  (dolist (part format-object)
    (cond
      ((eq :index part)
       (format stream "~A" index))
      ((stringp part)
       (format stream "~A" part))
      (t (funcall part stream info)))))

(defun print-format-info (&optional (stream t))
  (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
The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
  (dolist (entry *trashinfo-formatters*)
    (let ((char (first entry))
          (doc (third entry)))
      (format stream "  \"%~A\" - ~A~%" char doc))))


;; Sorting
(defun clingon-sort-options ()
  "Return a list of sorting options that can be used by many commands."
  (list
   (clingon:make-option
    :flag
    :key :reverse-sort
    :description "reverse sort order"
    :short-name #\r
    :long-name "reverse-sort")
   (clingon:make-option
    :enum
    :key :sort-field
    :description "sort field"
    :short-name #\l
    :long-name "sort-field"
    :items '(("name" . :name)
             ("path" . :path)
             ("deletion-date" . :deletion-date))
    :initial-value "deletion-date")))

(defun sort-trashinfos-for-cmd (trashinfos cmd)
  "Sort the TRASHINFOS according to options passed to CMD."
  (multiple-value-bind (pred-fun key-fun)
      (case (clingon:getopt cmd :sort-field)
        (:name (values #'string-lessp
                       (lambda (info) (file-or-dir-namestring
                                       (trashinfo-original-path info)))))
        (:path (values #'string-lessp #'trashinfo-original-path))
        (:deletion-date (values
                         #'< (lambda (info) (local-time:timestamp-to-unix
                                             (trashinfo-deletion-date info))))))
    (sort trashinfos
          (if (clingon:getopt cmd :reverse-sort)
              (complement pred-fun)
              pred-fun)
          :key key-fun)))


;; List command
(defun list/handler (cmd)
  "Handler for the \"list\" subcommand."
  (if (clingon:getopt cmd :print-format-info)
      (print-format-info t)
      (let ((format (process-format-string (or (clingon:getopt cmd :format)
                                               "%t  %o\\n"))))
        (loop for info in (sort-trashinfos-for-cmd
                           (list-trashinfos-for-cmd cmd) cmd)
              for i upfrom 1
              do (format-trashinfo t format info :index i)))))

(defun list/options ()
  "Return options for the \"list\" subcommand."
  (append
   (clingon-filtering-options)
   (clingon-sort-options)
   (list
    (clingon:make-option
     :list/filepath
     :key :extra-trashes
     :description "include additional trashes"
     :short-name #\c
     :long-name "include-trash"))))

(defun list/command ()
  "Return the Clingon command for the \"list\" subcommand."
  (clingon:make-command
   :name "list"
   :description "list files in trash directories"
   :usage "[options] [pattern]"
   :options (list/options)
   :handler #'list/handler))


;; Put command
(defun put/handler (cmd)
  "Handler for the \"put\" subcommand."
  (let ((no-cross-device (clingon:getopt cmd :no-cross-device))
        (ignored-dirs (clingon:getopt cmd :ignored-trashes))
        (trash-directory (clingon:getopt cmd :trash-directory)))
    (dolist (file (clingon:command-arguments cmd))
      (handler-case
          (cl-xdg-trash:trash-file file :no-cross-device no-cross-device
                                        :ignored-trash-dirs ignored-dirs
                                        :trash-directory trash-directory)
        ;; in case of an error, just notify the user and continue
        (error (e)
          (format *error-output* "~&~A~&" e))))))

(defun put/options ()
  "Return options for the \"put\" subcommand."
  (list
   (clingon:make-option
    :filepath
    :key :trash-directory
    :description "force trashing to a specific directory"
    :long-name "trash-directory")
   (clingon:make-option
    :flag
    :key :no-cross-device
    :description "don't trash files to directories on different devices"
    :short-name #\n
    :long-name "no-cross-device")))

(defun put/command ()
  "Return the Clingon command for the \"put\" subcommand"
  (clingon:make-command
   :name "put"
   :aliases '("trash")
   :description "move files to the trash"
   :usage "[-n|--no-cross-device] [--trash-directory=DIR] [files...]"
   :options (put/options)
   :handler #'put/handler))


;; Restore command

(defun restore/handler (cmd)
  "Handler for the \"restore\" subcommand."
  (le))

(defun restore/options ()
  "Return options for the \"restore\" subcommand."
  (append
   (clingon-filtering-options)
   (clingon-sort-options)
   (list
    (clingon:make-option
     :flag
     :key :all
     :description "restore all files that match the pattern"
     :short-name #\a
     :long-name "all")
    (clingon:make-option
     :list/integer
     :key :indices
     :description
     "restore the Nth file that matched the pattern (after sorting)"
     :short-name #\n
     :long-name "nth")
    (clingon:make-option
     :flag
     :key :dont-prompt-only-one
     :descrition "don't prompt if the pattern matches only one file"
     :short-name #\O
     :long-name "dont-prompt-only-one"))))

(defun restore/command ()
  "Rethrn the Clingon command for the \"restore\" subcommand."
  (clingon:make-command
   :name "restore"
   :descrition "move files out of the trash"
   :usage "[options] [pattern]"
   :options (restore/options)
   :handler #'restore/handler))


;; Toplevel command
(defun toplevel/options ()
  "Return the toplevel options list."
  (list
   (clingon:make-option
    :list
    :key :ignored-trashes
    :description "ignore the given trash directory"
    :long-name "ignore-trash"
    :persistent t)))

(defun toplevel/command ()
  "Return the toplevel command."
  (clingon:make-command
   :name "clash"
   :description "command line interface to the XDG trashcan"
   :version "0.1.0"
   :license "GPL3"
   :authors '("Alexander Rosenberg <zanderpkg@pm.me>")
   :options (toplevel/options)
   :sub-commands (list (list/command)
                       (put/command))
   :handler #'(lambda (cmd)
                (clingon:print-usage-and-exit cmd t))))

(defparameter *toplevel/help-option*
  (clingon:make-option
   :flag
   :key :clingon.help.flag
   :description "display usage information, then exit"
   :short-name #\h
   :long-name "help"
   :persistent t)
  "Help option to replace the default Clingon one.")

(defun toplevel (&optional (args () argsp))
  "Program entry point.
Args can be supplied to facilitate testing in SLIME."
  (let ((clingon:*default-options* (list clingon:*default-version-flag*
                                         clingon:*default-bash-completions-flag*
                                         *toplevel/help-option*)))
    (if argsp
        (clingon:run (toplevel/command) args)
        (clingon:run (toplevel/command)))))