;;; synaxis-filter.el --- Filter mini-language  -*- lexical-binding: t; -*-

;; Copyright (C) 2026 Thanos Apollo

;; Author: Thanos Apollo <public@thanosapollo.org>
;; Maintainer: Thanos Apollo <public@thanosapollo.org>
;; Keywords: news, hypermedia, rss, atom
;; URL: https://git.thanosapollo.org/synaxis

;; This file is NOT part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Filter mini-language with notmuch/forgejo-style KEY:VALUE tokens,
;; compiled to a SQL WHERE clause and parameter list.
;;
;; Supported tokens:
;;
;;   tag:K        -tag:K          require / forbid tag K
;;   feed:V       -feed:V         feed title contains / does not contain V
;;   title:V      -title:V        entry title contains / does not contain V
;;   content:V    -content:V      entry content contains / does not contain V
;;   date:SPEC                    see `synaxis-filter-parse-date-spec'
;;                                bare date:now... becomes a filter
;;                                interval at token classification;
;;                                parse-date-spec and comparisons keep
;;                                point specs for now-forms
;;   date:>=VALUE date:<VALUE     single SQL comparison on e.date
;;   date:>VALUE  date:<=VALUE      "
;;   limit:N                      cap the result count
;;   WORD                         free text in (title OR content); AND-ed
;;
;; All non-empty whitespace-separated tokens are AND-ed.  Unknown
;; prefixes are silently dropped.  -date: and -limit: are
;; meaningless and ignored.  Bare-word negation (-WORD) is not
;; supported in v0.1.1 -- use -title: or -content: instead.
;;
;; Multi-word values go in double quotes: title:"drug something"
;; matches via SQL LIKE %drug something% (case-insensitive).
;;
;; Date values understand the keywords today, yesterday,
;; thisweek, thismonth, thisyear, ISO forms YYYY,
;; YYYY-MM, YYYY-MM-DD, relative offsets 7d, 1y,
;; 30months, and the arithmetic form now, now-Nunit,
;; now+Nunit.  Bare date:now is open-ended from now;
;; bare date:now-Nunit is the trailing window to now.
;; Comparison operators (>=, <=, >, <)
;; produce one SQL clause each; `date:>2024-03' means "strictly
;; after March 2024".  Use `M-x synaxis-filter-explain' to view
;; the compiled WHERE and parameters for any filter string.

;;; Code:

(require 'cl-lib)
(require 'synaxis-db)

;;; Date parsing

(defun synaxis-filter--day-bounds (year month day)
  "Return (FROM . TO) `float-time' bounds for the day at YEAR, MONTH, DAY."
  (let* ((from (float-time (encode-time 0 0 0 day month year)))
         (to   (+ from 86400)))
    (cons from to)))

(defun synaxis-filter--keyword-date (s)
  "Parse keyword date S; nil otherwise.
Recognised: today, yesterday, thisweek, thismonth, thisyear."
  (pcase s
    ("today"
     (let* ((d (decode-time))
            (bounds (synaxis-filter--day-bounds
                     (decoded-time-year d)
                     (decoded-time-month d)
                     (decoded-time-day d))))
       (list :from (car bounds) :to (cdr bounds))))
    ("yesterday"
     (let* ((d (decode-time (time-subtract (current-time) 86400)))
            (bounds (synaxis-filter--day-bounds
                     (decoded-time-year d)
                     (decoded-time-month d)
                     (decoded-time-day d))))
       (list :from (car bounds) :to (cdr bounds))))
    ("thisweek"
     (let* ((now (current-time))
            (d   (decode-time now))
            (dow (decoded-time-weekday d))   ; 0=Sunday..6=Saturday
            (mondays-back (if (zerop dow) 6 (1- dow)))
            (monday (time-subtract now (* mondays-back 86400)))
            (md (decode-time monday))
            (bounds (synaxis-filter--day-bounds
                     (decoded-time-year md)
                     (decoded-time-month md)
                     (decoded-time-day md))))
       (list :from (car bounds) :to (float-time now))))
    ("thismonth"
     (let* ((now (current-time))
            (d   (decode-time now))
            (from (float-time (encode-time 0 0 0 1
                                           (decoded-time-month d)
                                           (decoded-time-year d)))))
       (list :from from :to (float-time now))))
    ("thisyear"
     (let* ((now (current-time))
            (d   (decode-time now))
            (from (float-time (encode-time 0 0 0 1 1
                                           (decoded-time-year d)))))
       (list :from from :to (float-time now))))))

(defun synaxis-filter--absolute-date (s)
  "Parse absolute date S: YYYY, YYYY-MM, or YYYY-MM-DD; nil otherwise.
Rejects months outside 1-12 and days outside 1-31 (`encode-time'
would otherwise silently normalise out-of-range values)."
  (cond
   ((string-match "\\`\\([0-9]\\{4\\}\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)\\'" s)
    (let ((year  (string-to-number (match-string 1 s)))
          (month (string-to-number (match-string 2 s)))
          (day   (string-to-number (match-string 3 s))))
      (and (<= 1 month 12) (<= 1 day 31)
           (let ((bounds (synaxis-filter--day-bounds year month day)))
             (list :from (car bounds) :to (cdr bounds))))))
   ((string-match "\\`\\([0-9]\\{4\\}\\)-\\([0-9]\\{1,2\\}\\)\\'" s)
    (let ((year  (string-to-number (match-string 1 s)))
          (month (string-to-number (match-string 2 s))))
      (and (<= 1 month 12)
           (let* ((from  (float-time (encode-time 0 0 0 1 month year)))
                  (next-month (if (= month 12) 1 (1+ month)))
                  (next-year  (if (= month 12) (1+ year) year))
                  (to (float-time (encode-time 0 0 0 1 next-month next-year))))
             (list :from from :to to)))))
   ((string-match "\\`\\([0-9]\\{4\\}\\)\\'" s)
    (let* ((year (string-to-number (match-string 1 s)))
           (from (float-time (encode-time 0 0 0 1 1 year)))
           (to   (float-time (encode-time 0 0 0 1 1 (1+ year)))))
      (list :from from :to to)))))

(defun synaxis-filter--duration-seconds (n unit)
  "Return seconds for N units of UNIT (string).
Recognised units: s, m, h, d, w, months, y.  nil otherwise."
  (let ((mult (pcase unit
                ("s"      1)
                ("m"      60)
                ("h"      3600)
                ("d"      86400)
                ("w"      604800)
                ("months" 2592000)
                ("y"      31536000))))
    (and mult (* n mult))))

(defun synaxis-filter--relative-date (s)
  "Parse relative date S (e.g. `7d', `1y'); nil otherwise."
  (and (string-match
        "\\`\\([0-9]+\\)\\(months\\|s\\|m\\|h\\|d\\|w\\|y\\)\\'"
        s)
       (and-let* ((secs (synaxis-filter--duration-seconds
                         (string-to-number (match-string 1 s))
                         (match-string 2 s)))
                  (now (float-time)))
         (list :from (- now secs) :to now))))

(defun synaxis-filter--now-date (s)
  "Parse S as `now', `now-Nunit', or `now+Nunit'; nil otherwise.
Returns a `(:from T :to T)' plist where T is the resolved epoch.
Point values are for comparison operators; bare `date:now...' tokens
expand via `synaxis-filter--bare-now-date'."
  (and (string-match
        "\\`now\\(?:\\([-+]\\)\\([0-9]+\\)\\(months\\|s\\|m\\|h\\|d\\|w\\|y\\)\\)?\\'"
        s)
       (let ((now (float-time))
             (sign (match-string 1 s)))
         (if (null sign)
             (list :from now :to now)
           (and-let* ((secs (synaxis-filter--duration-seconds
                             (string-to-number (match-string 2 s))
                             (match-string 3 s)))
                      (delta (if (equal sign "-") (- secs) secs))
                      (resolved (+ now delta)))
             (list :from resolved :to resolved))))))

(defun synaxis-filter--bare-now-date (s)
  "Parse bare now-form S into a non-degenerate filter interval, or nil.
`now' is open-ended from the current epoch (`:to' nil).
`now-Nunit' is the trailing window from that past point to now.
`now+Nunit' is the forward window from now to that future point.
Comparison operators still use `synaxis-filter--now-date' point specs."
  (and (string-match
        "\\`now\\(?:\\([-+]\\)\\([0-9]+\\)\\(months\\|s\\|m\\|h\\|d\\|w\\|y\\)\\)?\\'"
        s)
       (let ((now (float-time))
             (sign (match-string 1 s)))
         (if (null sign)
             (list :from now :to nil)
           (and-let* ((secs (synaxis-filter--duration-seconds
                             (string-to-number (match-string 2 s))
                             (match-string 3 s))))
             (if (equal sign "-")
                 (list :from (- now secs) :to now)
               (list :from now :to (+ now secs))))))))

(defun synaxis-filter--simple-date-spec (s)
  "Dispatch S to one of the simple-date sub-parsers."
  (or (synaxis-filter--keyword-date s)
      (synaxis-filter--now-date s)
      (synaxis-filter--absolute-date s)
      (synaxis-filter--relative-date s)))

(defun synaxis-filter-parse-date-spec (s)
  "Parse date spec S into a plist `(:from F :to T)' or nil.
F and T are `float-time' bounds; either may be nil (open end).
Supports ranges of the form LO..HI, LO.., and ..HI."
  (cond
   ((not (stringp s)) nil)
   ((string-empty-p s) nil)
   ((string-match "\\`\\(.*\\)\\.\\.\\(.*\\)\\'" s)
    (let* ((lo-str (match-string 1 s))
           (hi-str (match-string 2 s))
           (lo (and (not (string-empty-p lo-str))
                    (synaxis-filter--simple-date-spec lo-str)))
           (hi (and (not (string-empty-p hi-str))
                    (synaxis-filter--simple-date-spec hi-str)))
           (from (and lo (plist-get lo :from)))
           (to   (and hi (plist-get hi :to))))
      (and (or from to) (list :from from :to to))))
   (t (synaxis-filter--simple-date-spec s))))

(defun synaxis-filter--date-cmp-boundary (op spec)
  "Pick the boundary epoch from SPEC for OP.
SPEC is a `(:from F :to T)' plist.  `>=' and `<' use :from; `>' and
`<=' use :to.  This makes operator semantics correct for both point
values (where :from = :to) and span values like `2024-03-15' or
`2024-03'."
  (pcase op
    ((or ">=" "<") (plist-get spec :from))
    ((or ">" "<=") (plist-get spec :to))))

(defun synaxis-filter--date-cmp-token (val)
  "Parse VAL as OPSPEC and return a date-cmp cell, or nil.
Returns nil when VAL has no operator prefix or SPEC is unparseable."
  (and (string-match "\\`\\(>=\\|<=\\|>\\|<\\)\\(.+\\)\\'" val)
       (and-let* ((op (match-string 1 val))
                  (spec (synaxis-filter--simple-date-spec
                         (match-string 2 val)))
                  (time (synaxis-filter--date-cmp-boundary op spec)))
         (cons 'date-cmp (list :op op :time time)))))

;;; Token classification

(defun synaxis-filter--token-for (key val negated)
  "Build a token cell for KEY=VAL, optionally NEGATED.
`feed', `title', and `content' values match via SQL LIKE
`%VAL%' (case-insensitive)."
  (pcase key
    ((or 'feed 'title 'content)
     (cons (intern (format "%s%s" (if negated "not-" "") key)) val))
    ('tag   (cons (if negated 'not-tag 'tag) val))
    ('date  (and (not negated)
                 (or (synaxis-filter--date-cmp-token val)
                     (let ((spec (or (synaxis-filter--bare-now-date val)
                                     (synaxis-filter-parse-date-spec val))))
                       (and spec (cons 'date spec))))))
    ('limit (and (not negated)
                 (let ((n (string-to-number val)))
                   (and (> n 0) (cons 'limit n)))))))

(defun synaxis-filter--classify-prefixed (tok negated)
  "Classify TOK as a `prefix:value' token.
If TOK has no `:', treat as a bare word, or drop when NEGATED."
  (cond
   ((string-match "\\`\\([a-z]+\\):\\(.+\\)\\'" tok)
    (synaxis-filter--token-for
     (intern (match-string 1 tok))
     (match-string 2 tok)
     negated))
   (negated nil)              ;; `-WORD' unsupported
   (t (cons 'text tok))))

(defun synaxis-filter--classify (tok)
  "Classify a single whitespace-separated TOK; return token cell or nil."
  (cond
   ((string-empty-p tok) nil)
   ((string-prefix-p "-" tok)
    (synaxis-filter--classify-prefixed (substring tok 1) t))
   (t (synaxis-filter--classify-prefixed tok nil))))

(defun synaxis-filter--tokenize (s &optional keep-quotes)
  "Split S into tokens, respecting double-quoted segments.
Whitespace inside `\"...\"' is preserved.  `\\\"' inside a quoted
segment becomes a literal `\"'.  Empty tokens are dropped.  An
unmatched opening quote is treated as if closed at end-of-string.

When KEEP-QUOTES is non-nil, retain quote delimiters and escaped
quotes in the returned tokens."
  (named-let walk ((i 0) (in-quote nil) (cur nil) (out nil))
    (let ((flush (lambda (acc xs)
                   (let ((tok (and acc (apply #'string (nreverse acc)))))
                     (if (and tok (not (string-empty-p tok)))
                         (cons tok xs)
                       xs)))))
      (cond
       ((>= i (length s))
        (nreverse (funcall flush cur out)))
       ((and in-quote (eq (aref s i) ?\\)
             (< (1+ i) (length s))
             (eq (aref s (1+ i)) ?\"))
        (walk (+ i 2) t
              (if keep-quotes
                  (cons ?\" (cons ?\\ cur))
                (cons ?\" cur))
              out))
       ((eq (aref s i) ?\")
        (walk (1+ i) (not in-quote)
              (if keep-quotes (cons ?\" cur) cur)
              out))
       ((and (not in-quote) (memq (aref s i) '(?\s ?\t ?\n)))
        (walk (1+ i) nil nil (funcall flush cur out)))
       (t
        (walk (1+ i) in-quote (cons (aref s i) cur) out))))))

(defun synaxis-filter-parse (s)
  "Tokenise filter string S into a list of token cells.
Double-quoted segments are taken as literal values; whitespace
inside quotes is preserved.  See `synaxis-filter--tokenize'."
  (delq nil
        (mapcar #'synaxis-filter--classify
                (synaxis-filter--tokenize (or s "")))))

;;; Compiler

(defun synaxis-filter--iso (time)
  "Format TIME (float epoch or Lisp time value) as canonical UTC ISO 8601."
  (format-time-string "%Y-%m-%dT%H:%M:%SZ" time t))

(defconst synaxis-filter--exists-sql
  "EXISTS (SELECT 1 FROM entry_tags t WHERE t.entry_id = e.id AND t.tag = ?)")

(defconst synaxis-filter--not-exists-sql
  (concat "NOT " synaxis-filter--exists-sql))

(defun synaxis-filter--like-clause (col negated)
  "SQL fragment matching COL with LIKE.  Negate when NEGATED."
  (format "%s %s ? COLLATE NOCASE" col (if negated "NOT LIKE" "LIKE")))

(defun synaxis-filter--like-token (col tok negated)
  "Return (CLAUSE . PARAM) for a LIKE token on COL with value TOK.
Negated when NEGATED."
  (cons (synaxis-filter--like-clause col negated)
        (format "%%%s%%" tok)))

(defun synaxis-filter-compile (tokens)
  "Compile parsed TOKENS into a plist.
Returns (:where S :params P :limit L)."
  (let (parts params limit)
    (cl-flet ((emit (clause &rest ps)
                (push clause parts)
                (dolist (p ps) (push p params))))
      (dolist (tok tokens)
        (pcase-exhaustive (car tok)
          ('tag         (emit synaxis-filter--exists-sql     (cdr tok)))
          ('not-tag     (emit synaxis-filter--not-exists-sql (cdr tok)))
          ('feed        (pcase-let ((`(,c . ,p) (synaxis-filter--like-token "f.title" (cdr tok) nil)))
                          (emit c p)))
          ('not-feed    (pcase-let ((`(,c . ,p) (synaxis-filter--like-token "f.title" (cdr tok) t)))
                          (emit c p)))
          ('title       (pcase-let ((`(,c . ,p) (synaxis-filter--like-token "e.title" (cdr tok) nil)))
                          (emit c p)))
          ('not-title   (pcase-let ((`(,c . ,p) (synaxis-filter--like-token "e.title" (cdr tok) t)))
                          (emit c p)))
          ('content     (pcase-let ((`(,c . ,p) (synaxis-filter--like-token "e.content" (cdr tok) nil)))
                          (emit c p)))
          ('not-content (pcase-let ((`(,c . ,p) (synaxis-filter--like-token "e.content" (cdr tok) t)))
                          (emit c p)))
          ('text
           (let ((wild (format "%%%s%%" (cdr tok))))
             (emit "(e.title LIKE ? COLLATE NOCASE OR e.content LIKE ? COLLATE NOCASE)"
                   wild wild)))
          ('date
           (let ((from (plist-get (cdr tok) :from))
                 (to   (plist-get (cdr tok) :to)))
             (when from (emit "e.date >= ?" (synaxis-filter--iso from)))
             (when to   (emit "e.date < ?"  (synaxis-filter--iso to)))))
          ('date-cmp
           (let* ((cmp (cdr tok))
                  (op (plist-get cmp :op))
                  (sql-op (pcase op
                            ((or ">=" ">") ">=")
                            ((or "<=" "<") "<")))
                  (time (plist-get cmp :time)))
             (emit (format "e.date %s ?" sql-op)
                   (synaxis-filter--iso time))))
          ('limit (setq limit (cdr tok))))))
    (list :where  (if parts (string-join (nreverse parts) " AND ") "1=1")
          :params (nreverse params)
          :limit  limit)))

;;; Completions

(defconst synaxis-filter--static-completions
  '("tag:" "-tag:" "feed:" "-feed:" "title:" "-title:"
    "content:" "-content:" "date:" "limit:"
    "date:today" "date:yesterday"
    "date:thisweek" "date:thismonth" "date:thisyear"
    "date:7d" "date:30d" "date:1y"
    "date:now" "date:now-7d" "date:now-30d" "date:now-1y"
    "date:>=now-7d" "date:>=now-30d" "date:<now")
  "Static completion strings independent of DB state.")

(defun synaxis-filter--db-tags ()
  "Return the list of registered tag strings, alphabetically.
Reads from the `tags' registry (schema v2+); no DISTINCT scan."
  (let ((db (synaxis-db--ensure-open)))
    (mapcar #'car
            (sqlite-select
             db "SELECT tag FROM tags ORDER BY tag COLLATE NOCASE;"))))

(defun synaxis-filter--db-feed-titles ()
  "Return the list of non-empty feed titles in the database."
  (let ((db (synaxis-db--ensure-open)))
    (mapcar #'car
            (sqlite-select
             db "SELECT title FROM feeds
                 WHERE title IS NOT NULL AND title <> ''
                 ORDER BY title COLLATE NOCASE;"))))

(defun synaxis-filter--quote-if-needed (s)
  "Wrap S in double quotes when whitespace is present."
  (if (and (stringp s) (string-match-p "[ \t]" s))
      (format "\"%s\"" s)
    s))

(defun synaxis-filter--prefix-each (prefix values)
  "Return VALUES with PREFIX prepended, quoting whitespace-containing items."
  (mapcar (lambda (v)
            (concat prefix (synaxis-filter--quote-if-needed v)))
          values))

(defun synaxis-filter-completions ()
  "Return a list of completion candidate strings for the filter prompt.
Entry titles are intentionally omitted; `title:' matches via SQL
LIKE `%VAL%' so the value is free text the user types directly."
  (let ((tags  (synaxis-filter--db-tags))
        (feeds (synaxis-filter--db-feed-titles)))
    (append synaxis-filter--static-completions
            (synaxis-filter--prefix-each "tag:"   tags)
            (synaxis-filter--prefix-each "-tag:"  tags)
            (synaxis-filter--prefix-each "feed:"  feeds)
            (synaxis-filter--prefix-each "-feed:" feeds))))

;;; Explain

(defun synaxis-filter--explain-render (filter tokens spec)
  "Render an explain view for FILTER, TOKENS, and compiled SPEC.
Writes into the current buffer."
  (insert (format "Filter: %s\n\n" filter))
  (insert "Tokens:\n")
  (if tokens
      (dolist (tok tokens)
        (insert (format "  %s\n" (prin1-to-string tok))))
    (insert "  (none)\n"))
  (insert "\nWHERE:\n")
  (let* ((where (plist-get spec :where))
         (parts (split-string where " AND " t)))
    (dolist (p parts)
      (insert (format "  %s\n" p))))
  (insert "\nParameters:\n")
  (let ((params (plist-get spec :params)))
    (if params
        (dolist (p params)
          (insert (format "  %s\n" (prin1-to-string p))))
      (insert "  (none)\n")))
  (insert "\nLimit: ")
  (let ((explicit (plist-get spec :limit))
        (default (and (boundp 'synaxis-search-default-limit)
                      synaxis-search-default-limit)))
    (insert (cond
             (explicit (format "%d\n" explicit))
             (default  (format "%d (default)\n" default))
             (t        "(none)\n")))))

;;;###autoload
(defun synaxis-filter-explain (filter)
  "Show the compiled SQL for FILTER in a pop-up buffer.
Interactively, default to the active search filter."
  (interactive
   (list (read-string "Explain filter: "
                      (or (and (boundp 'synaxis-search--filter)
                               synaxis-search--filter)
                          ""))))
  (let* ((tokens (synaxis-filter-parse filter))
         (spec (synaxis-filter-compile tokens))
         (buf (get-buffer-create "*Synaxis Filter Explain*")))
    (with-current-buffer buf
      (let ((inhibit-read-only t))
        (erase-buffer)
        (synaxis-filter--explain-render filter tokens spec))
      (goto-char (point-min))
      (special-mode))
    (pop-to-buffer buf)))

(provide 'synaxis-filter)
;;; synaxis-filter.el ends here
