;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/tg/type-macros
  (:documentation "Macros for easy defining TG types.")
  (:use :c2cl :iterate)
  (:import-from :alexandria :with-gensyms)
  (:import-from :com.dieggsy.f-string :enable-f-strings)
  (:import-from :str)
  (:import-from :ukkoclot/serializing :parse-value)
  (:import-from :ukkoclot/hash-tables :gethash-lazy)
  (:local-nicknames
   (:jzon :com.inuoe.jzon))
  (:export :define-tg-type))
(in-package :ukkoclot/tg/type-macros)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (enable-f-strings))

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

  (defparameter +unique+ (gensym))

  ;; TODO: Fix optional-and-key !
  (defun make-field (name type          ; lint:suppress avoid-optional-and-key
                     &optional (default +unique+)
                     &key (skip-if-default (not (eq default +unique+))))
    (let ((default (if (eq default +unique+)
                       `(error ,#f"No value given for {name}")
                       default)))
      (make-field% :name name
                   :type type
                   :default default
                   :skip-if-default skip-if-default)))

  (defun type-constructor (name)
    (intern (concatenate 'string "MAKE-" (symbol-name name))))

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

  (defun field-hash-key (field)
    (str:snake-case (field-name field)))

  (defun field-keyword (field)
    (intern (symbol-name (field-name field)) :keyword))

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

  (defun emit-append-to-pprint-args (field value pprint-args)
    `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))

  (defun emit-coerced-field (field value)
    `(list ,(field-hash-key field) ,value ',(field-type field)))

  (defun emit-collect-nondefault-fields (name fields obj collector)
    (with-gensyms (value)
      (iter (for field in (reverse fields))
            (collect
                (if (field-skip-if-default field)
                    `(let ((,value (,(field-accessor name field) ,obj)))
                       (unless (equal ,value ,(field-default field))
                         ,(funcall collector field value)))
                    (funcall collector field (list (field-accessor name field) obj)))))))

  (defun emit-constructor-args (field)
    `(,(field-keyword field) ,(field-name field)))

  (defun emit-gethash (field source)
    `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field)))

  (defun emit-jzon-coerced-fields (name fields)
    (with-gensyms (obj result)
      `(defmethod jzon:coerced-fields ((,obj ,name))
         (let (,result)
           ,@(emit-collect-nondefault-fields
              name fields obj
              (lambda (field value)
                `(push ,(emit-coerced-field field value) ,result)))
           ,result))))

  (defun emit-let-gethash (field source)
    `(,(field-name field)
      (parse-value ',(field-type field) ,(emit-gethash field source))))

  (defun emit-parse-value (name fields)
    (with-gensyms (source type)
      `(defmethod parse-value ((,type (eql ',name)) ,source)
         (let (,@(iter (for field in fields)
                       (collect (emit-let-gethash field source))))
           (,(type-constructor name)
            ,@(iter (for field in fields)
                    (appending (emit-constructor-args field))))))))

  (defun emit-printer (name printer-name fields)
    (with-gensyms (depth obj pprint-args stream)
      `(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid
         (declare (ignore ,depth))
         (let (,pprint-args)
           ,@(emit-collect-nondefault-fields
              name fields obj
              (lambda (field value)
                `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args))))
           (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))))

  (defun emit-struct (name printer-name fields)
    `(defstruct (,name (:print-function ,printer-name))
       ,@(iter (for field in fields)
               (collect (emit-struct-field field)))))

  (defun emit-struct-field (field)
    `(,(field-name field) ,(field-default field) :type ,(field-type field))))

(defmacro define-tg-type (name &body field-specs)
  (let ((fields (parse-field-specs field-specs)))
    (with-gensyms (printer)
      `(progn
         ,(emit-struct name printer fields)
         ,(emit-printer name printer fields)
         ,(emit-parse-value name fields)
         ,(emit-jzon-coerced-fields name fields)))))