
;; Copyright (C) 2024 Tommi Höynälänmaa

;; Distributed under GNU Lesser General Public Licence version 3,
;; see file doc/LGPL-3.


(define-module (th-scheme-utilities hrecord)
  #:duplicates (merge-generics replace last)
  #:declarative? #t
  #:export (hrecord-type
            hrecord-type?
            hrecord?
            hrecord-type-get-name
            hrecord-type-get-field-count
            hrecord-type-get-parent
            hrecord-type-get-fields
            hrecord-type-get-all-fields
            %get-field-index
            make-hrecord
            hfield-ref
            hfield-set!
            hrecord-type-of
            hrecord-type=?
            hrecord=?
            hrecord-is-direct-instance?
            hrecord-type-is-subtype?
            hrecord-is-instance0?
            hrecord-is-instance?
            make-hrecord-type
            hrecord-type-name-of
            get-hrecord-type-predicate0
            get-hrecord-type-predicate
            define-hrecord-type))


(import (oop goops)
        (rnrs base)
        (th-scheme-utilities stdutils))


(define (hrecord-type? x)
  (is-a? x <class>))

(define hrecord? instance?)

(define hrecord-type-get-name class-name)

(define (hrecord-type-get-field-count clas)
  (length (class-slots clas)))

(define (hrecord-type-get-parent clas)
  (let ((l-direct-supers (class-direct-supers clas)))
    (if (null? l-direct-supers)
      '()
      (begin
       ;; We don't allow multiple inheritance for hrecords.
       (strong-assert (null? (cdr l-direct-supers)))
       (car l-direct-supers)))))

(define (hrecord-type-get-fields clas)
  (map slot-definition-name (class-direct-slots clas)))

(define (hrecord-type-get-all-fields clas)
  (map slot-definition-name (class-slots clas)))

(define make-hrecord make1)

;; No checks here.
(define (%get-field-index x s-field-name)
  (let ((clas (class-of x)))
    (search s-field-name (hrecord-type-get-all-fields clas))))

(define hfield-ref slot-ref)

(define hfield-set! slot-set!)

(define hrecord-type-of class-of)

;; GOOPS objects should be compared with eqv? or equal?.
(define hrecord-type=? eqv?)

(define hrecord=? eqv?)

(define (hrecord-is-direct-instance? x clas)
  (assert (instance? x))
  (assert (is-a? clas <class>))
  (eqv? (class-of x) clas))

(define (hrecord-type-is-subtype? clas1 clas2)
  (if (memv clas2 (class-precedence-list clas1)) #t #f))

(define hrecord-is-instance0? is-a?)

;; Procedure is-a? accepts non-goops objects, too.
(define hrecord-is-instance? is-a?)

(define make-hrecord-type make-class1)

(define (hrecord-type-name-of x)
  (class-name (class-of x)))

(define (get-hrecord-type-predicate0 type)
  (lambda (obj) (is-a? obj type)))

(define (get-hrecord-type-predicate type)
  (lambda (obj) (is-a? obj type)))

(define-syntax define-hrecord-type
  (syntax-rules ()
    ((_ name ())
     (define name (make-hrecord-type (quote name) '() '())))
    ((_ name () field1 ...)
     (define name
       (make-hrecord-type (quote name) '() '(field1 ...))))
    ((_ name (parent))
     (define name (make-hrecord-type (quote name) parent '())))
    ((_ name (parent) field1 ...)
     (define name
       (make-hrecord-type (quote name) parent '(field1 ...))))))

  
