(declare (unit tick-query))

(module tick-query ()

(import scheme)
(import (chicken base)
        (chicken format)
        (chicken port)
        (chicken file)
        (chicken string))
(import commands simple-logger optimism srfi-13)
(import tick tick-params)

(define-command 'query
  (sprintf "\
query [<expr|named-query>] <options>
  Query the database using <expr> (a Scheme expression) or a named query
  (configured in the `named-queries' configuration parameter).

  If <expr|named-query> is not provided, the value of the `default-query'
  (~S) configuration parameter will be used.

  To see the configured named, queries, use `tick list named-queries'.

  <options>:
  --sort-by|-s <named-sorter>
    Use <named-sorter> instead of the default sorter, which orders tickets by
    creation time (newer ones first).  <named-sorter> are identifiers of
    sorters in the `named-sorters' parameter.

  --from-file|-F <file>
    Take a query from an external file instead of directly as an expression.

  --dry-run|-n
    Show the translated query instead of actually running it. This is
    intended mostly for debugging purposes.

  ~a

  Valid operators (polymorphic -- can be applied to strings, dates and numbers):
  * =   Equal
  * <>  Not equal (also !=)
  * <   Less than
  * >   Greater than
  * <=  Less than or equal
  * >=  Greater than or equal
  * ~~=  Equal, strings are compared case-insensitively
  * ~~   True if second argument matches the regular expression given in the
        first argument

  Bound variables and ticket accessors
  * me         Value of (get-username)
  * id         Ticket id (hash)
  * trac-id    Ticket Trac id (number, for tickets imported from Trac)
  * type       Ticket type
  * date       Ticket creation date (YYYY-MM-DD)
  * changetime Ticket last modification time (seconds)
  * component  Ticket component
  * difficulty Ticket estimated difficulty
  * priority   Ticket priority
  * owner      Ticket owner
  * reporter   Ticket reporter
  * cc         Ticket Cc
  * version    Ticket version
  * milestone  Ticket milestone
  * status     Ticket status
  * resolution Ticket resolution
  * summary    Ticket summary
  * body       Ticket body
  * keywords   Ticket keywords

  Examples:
    tick query '(and (<> status \"closed\") (= milestone \"6.0.0\"))'
    tick query '(and (= owner me) (<> status \"closed\"))'
    tick query '(and date (> date \"2022-11-01\") (~~ \"bar\" keywords))'

  Considering the following configuration of `named-queries'
  (can be configured with `define-named-query' in
  ~a, for example):

    (named-queries
      '((my-open-tickets (and (= owner me) (<> status \"closed\")) #f)))

    tick query my-open-tickets"
           (default-query)
           +format-option-help+
           +conf-file+)
  (lambda (args*)
    (let* ((args (parse-command-line
                  args*
                  `(((--format -f) . format)
                    ((--named-listing -L) . ,string->symbol)
                    ((--dry-run -n))
                    ((--from-file -F) . filename)
                    ((--sort-by -s) . sorter)
                    ((--) . query))))
           (format (get-opt '(--format -f) args))
           (named-listing (get-opt '(--named-listing -L) args))
           (filename (get-opt '(--from-file -F) args))
           (dry-run (get-opt '(--dry-run -n) args))
           (sort-by (get-opt '(--sort-by -s) args))
           (query (let ((rest (get-opt '(--) args)))
                    (if (null? rest)
                        (default-query)
                        (car rest)))))
      (when (and format named-listing)
        (die! "--format|-f and --named-listing|-L are mutually exclusive."))
      (let* ((expr #f)
             (nq-format #f) ;; listing format specified by define-named-query
             (get-named-query
              (lambda (named-query)
                (let ((expr/listing-format
                       (alist-ref named-query (named-queries))))
                  (unless expr/listing-format
                    (die! "Cannot find named query: ~a" named-query))
                  (set! expr (car expr/listing-format))
                  (set! nq-format (cadr expr/listing-format))))))
        (cond (filename
               (set! expr (with-input-from-file filename read)))
              ((string? query)
               (if (string-prefix? "(" query)
                   (set! expr (with-input-from-string query read))
                   (get-named-query (string->symbol query))))
              (else
               (if (string-prefix? "(" (->string query))
                   (set! expr query)
                   (get-named-query query))))
        (let* ((bindings (determine-query-required-bindings expr))
               (found? #f)
               (query (eval-query expr bindings dry-run)))
          (when (and nq-format (not (or format named-listing)))
            (customize-listing-format nq-format))
          ;; --format/--named-listing clobber the listing format
          ;; specified by define-named-query
          (let ((formatter
                 (if named-listing
                     (or (alist-ref named-listing (named-listings))
                         (die! "Invalid named listing: ~a" named-listing))
                     (begin
                       (when format
                         (customize-listing-format format))
                       (listing-format))))
                (results
                 (let loop ((ticket-ids (db-ticket-ids)))
                   (if (null? ticket-ids)
                       '()
                       (let* ((ticket (read-ticket (car ticket-ids)))
                              (res (query ticket)))
                         (unless dry-run
                           (if res
                               (begin
                                 (set! found? #t)
                                 (cons ticket (loop (cdr ticket-ids))))
                               (loop (cdr ticket-ids)))))))))
            (when dry-run
              (exit 0))
            (if found?
                (let ((sorter
                       (if sort-by
                           (or (and-let* ((s (alist-ref (string->symbol sort-by)
                                                        (named-sorters))))
                                 s)
                               (die! "--sort-by: No such named sorter: ~a"
                                     sort-by))
                           sort-tickets-by-creation-time)))
                  (with-output-to-pager
                   (lambda ()
                     (for-each formatter (sorter results)))))
                (exit 1))))))))
) ;; end module