;;; Weeb --- Web microframework for GNU Guile
;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This file is part of Weeb.
;;;
;;; Weeb is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Weeb 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 Affero General
;;; Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.

(define-module (weeb struct)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (json)
  #:export (define-struct
            make-struct
            instance-of?
            with-accessors
            call-with-slots
            ref
            struct->json-string
            json-string->struct))

;; Define a new record type with the given NAME and FIELDS.
(define-syntax define-struct
  (lambda (stx)
    (syntax-case stx ()
      ((_ name field* ...)
       #'(define name
           (let* ((type-string (symbol->string (quote name)))
                  (type-representation (match:substring
                                        (string-match "[^<> ]+" type-string))))
             (make-record-type (quote name)
                               (quote (field* ...)))))))))

(define (make-struct type . args)
  "Create a new instance of the record type TYPE using ARGS to
instantiate the record's fields."
  (apply (record-constructor type) args))

(define (instance-of? rtd type)
  "Returns true if RTD is an instance of TYPE."
  (and (record? rtd)
       ((record-predicate type) rtd)))

(define-syntax with-accessors
  (syntax-rules ()
    ((with-accessors (rtd field ...)
        body ...)
     (let ((rtd-eval rtd))
       (let ((field ((record-accessor (record-type-descriptor rtd) 'field) rtd))
             ...)
         body ...)))))

(define-syntax call-with-slots
  (syntax-rules ()
    ((call-with-slots rtd
        (lambda (field ...)
          body ...))
     (let ((rtd-eval rtd))
       (let ((field ((record-accessor (record-type-descriptor rtd) 'field) rtd))
             ...)
         body ...)))))

(define* (ref obj #:rest keys)
  (match keys
    (() obj)
    ((key rest ...)
     (if (or (not (record? obj))
             (not (record-accessor (record-type-descriptor obj) key)))
         #f
         (apply ref
                ((record-accessor (record-type-descriptor obj) key) obj)
                rest)))))

(read-hash-extend #\.
  (lambda (chr port)
    (let* ((sym (read port))
           (str (symbol->string sym))
           (parts (string-split str #\.)))
      (let ((symbols (map string->symbol parts)))
        (let ((base-obj (car symbols))
              (fields (cdr symbols)))
          (let ((quoted-fields (map (lambda (f) `',f) fields)))
            `(ref ,base-obj ,@quoted-fields)))))))

(define (struct->json-string x)
  (let ((descriptor (record-type-descriptor x)))
    (scm->json-string
     (map (lambda (field-name)
            (cons
             (symbol->string field-name)
             ((record-accessor descriptor field-name) x)))
          (record-type-fields descriptor)))))

(define (json-string->struct type-descriptor x)
  (let ((json-object (json-string->scm x)))
    (apply
     make-struct
     type-descriptor
     (map (lambda (field-name)
            (assoc-ref json-object (symbol->string field-name)))
          (record-type-fields type-descriptor)))))