;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/tg-types/macros
  (:use :c2cl)
  (:import-from :ukkoclot/bot/impl :bot :do-call :parse-value)
  (:import-from :ukkoclot/hash-tables :gethash-lazy)
  (:import-from :ukkoclot/strings :lisp->snake-case)
  (:local-nicknames
   (:jzon :com.inuoe.jzon))
  (:export :define-tg-method :define-tg-type))
(in-package :ukkoclot/tg-types/macros)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defstruct (field (:constructor make-field%)) name type default skip-if-default)

  (defparameter +unique+ (gensym))

  (defun make-field (name type &optional (default +unique+) &key (skip-if-default (not (eq default +unique+))))
    (let ((default (if (eq default +unique+)
                       (list 'error (format nil "No value given for ~A" name))
                       default)))
      (make-field% :name name
                   :type type
                   :default default
                   :skip-if-default skip-if-default)))

  (defun parse-field-specs (field-specs)
    (loop for field-spec in field-specs
          collect (apply #'make-field field-spec)))

  (defun field-hash-key (field)
    (string-downcase (lisp->snake-case (symbol-name (field-name field)))))

  (defun field-accessor (struc-name field)
    (intern (concatenate 'string (symbol-name struc-name) "-" (symbol-name (field-name field)))))

  (defun field->coerced-field-spec (field struc-name obj-name)
    `(list ,(string-downcase (lisp->snake-case (symbol-name (field-name field))))
           (,(field-accessor struc-name field) ,obj-name)
           ',(field-type field)))

  (defun field->defun-spec (field)
    (list (field-name field) (field-default field)))

  (defun field->format-arg (field name struc)
    `(',(field-name field) (,(field-accessor name field) ,struc)))

  (defun field->ftype-spec (field)
    (list (intern (symbol-name (field-name field)) :keyword) (field-type field)))

  (defun field->gethash-spec (field hash-table-sym)
    (let ((hash-key (field-hash-key field)))
      (list 'gethash-lazy hash-key hash-table-sym (field-default field))))

  (defun field->sethash-spec (field name struc hash-table-sym)
    (let ((hash-key (field-hash-key field))
          (skip-if-default (field-skip-if-default field))
          (default (field-default field)))
      (if skip-if-default
          (let ((tmpsym (gensym "TMP")))
            `(let ((,tmpsym (,(field-accessor name field) ,struc)))
               (unless (equal ,tmpsym ,default)
                 (setf (gethash ,hash-key ,hash-table-sym) ,tmpsym))))
          `(setf (gethash ,hash-key ,hash-table-sym) (,(field-accessor name field) ,struc)))))

  (defun field->let-gethash-spec (field hash-table-sym)
    `(,(field-name field)
      (parse-value ',(field-type field) ,(field->gethash-spec field hash-table-sym))))

  (defun field->make-spec (field)
    (list (intern (symbol-name (field-name field)) :keyword)
          (field-name field)))

  (defun field->struct-spec (field)
    (list (field-name field) (field-default field) :type (field-type field))))

;; TODO: Automatically derive path from name
;; TODO: Automatically derive mapfn from type
(defmacro define-tg-method (
                            (name type path &optional (method :POST))
                            &body field-specs)
  (let* ((fields (parse-field-specs field-specs))
         (revfields (reverse fields))
         (args (gensym "ARGS"))
         (bot (gensym "BOT-")))
    `(progn
       (declaim (ftype (function (bot &key ,@(loop for field in fields
                                                 collect (field->ftype-spec field)))
                                 ,type)
                       ,name))
       (defun ,name (,bot &key ,@(loop for field in fields collect (field->defun-spec field)))
         (let (,args)
           ,@(loop for field in revfields
                   collecting
                   (if (field-skip-if-default field)
                       `(unless (equal ,(field-name field) ,(field-default field))
                          (setf ,args (acons ',(field-name field) ,(field-name field) ,args)))
                       `(setf ,args (acons ',(field-name field) ,(field-name field) ,args))))
           (do-call ,bot ,method ,path ',type ,args))))))

(defmacro define-tg-type (name &body field-specs)
  (let* ((fields (parse-field-specs field-specs))
         (revfields (reverse fields))
         (make-name (intern (concatenate 'string "MAKE-" (symbol-name name))))
         (printer (gensym (concatenate 'string "PRINT-" (symbol-name name))))
         (hash (gensym "HASH-"))
         (struc (gensym (symbol-name name)))
         (stream (gensym "STREAM"))
         (depth (gensym "DEPTH"))
         (pprint-args (gensym "PPRINT-ARGS"))
         (res (gensym "RES"))
         (type (gensym "TYPE")))
    `(progn
       (defstruct (,name (:print-function ,printer))
         ,@(loop for field in fields
                 collect (field->struct-spec field)))
       (defun ,printer (,struc ,stream ,depth)
         (declare (ignore ,depth))
         (let (,pprint-args)
           ,@(loop for field in revfields
                   collecting
                   (if (field-skip-if-default field)
                       `(let ((value (,(field-accessor name field) ,struc)))
                          (unless (equal value ,(field-default field))
                            (setf ,pprint-args (list* ',(field-name field) value ,pprint-args))))
                       `(setf ,pprint-args (list* ',(field-name field) (,(field-accessor name field) ,struc) ,pprint-args))))
         (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))
       (defmethod parse-value ((,type (eql ',name)) ,hash)
         (let ,(loop for field in fields
                     collect (field->let-gethash-spec field hash))
           (,make-name ,@(loop for field in fields
                               append (field->make-spec field)))))
       (defmethod jzon:coerced-fields ((,struc ,name))
         (let (,res)
           ,@(loop for field in revfields
                   collecting
                   (if (field-skip-if-default field)
                       `(let ((value (,(field-accessor name field) ,struc)))
                          (unless (equal value ,(field-default field))
                            (setf ,res (cons ,(field->coerced-field-spec field name struc) ,res))))
                       `(setf ,res (cons ,(field->coerced-field-spec field name struc) ,res))))
           ,res)))))