;;; -*-scheme-*-

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; srfi-9.mes - records, based on struct.

(define-macro (define-record-type name constructor+params predicate . fields)
  (let ((type (make-record-type name (map car fields))))
   `(begin
      (define ,name ,type)
      (define ,(car constructor+params) ,(record-constructor type name (cdr constructor+params)))
      (define ,predicate ,(record-predicate type))
      (define-record-accessors ,type ,@fields))))

(define (make-record-type type fields . printer)
  (let ((printer (if (pair? printer) (car printer))))
    (make-struct '<record-type> (cons type (list fields)) printer)))

(define (record-type? o)
  (eq? (struct-vtable o) '<record-type>))

(define (struct-vtable o)
  (struct-ref o 0))

(define (record-type o)
  (struct-ref o 2))

(define (record-predicate type)
  (lambda (o)
    (and (record? o)
         (eq? (record-type o) (record-type type)))))

(define (record? o)
  (and (struct? o)
       (record-type? (struct-vtable o))))

(define (record-constructor type name params)
  (let ((fields (record-fields type))
        (record-type (record-type type)))
    (lambda (. o)
      (if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
          (let ((rest (make-list (- (length fields) (length params)))))
            (make-struct type (cons name (append o rest)) record-printer))))))

(define record-printer *unspecified*)   ; TODO
(define (record-printer o)
  (display "#<")
  (display (record-type o))
  (let* ((vtable (struct-vtable o))
         (fields (record-fields vtable)))
    (for-each (lambda (field)
                (display " ")
                (display field)
                (display ": ")
                (display ((record-getter vtable field) o)))
              fields))
  (display ">"))

(define (record-fields o)
  (struct-ref o 3))

(define-macro (define-record-accessors type . fields)
  `(begin
     ,@(map (lambda (field)
              `(define-record-accessor ,type ,field))
            fields)))

(define-macro (define-record-accessor type field)
  `(begin
     (define ,(cadr field) ,(record-getter type (car field)))
     (if ,(pair? (cddr field))
         (define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))

(define (record-getter type field)
  (let ((i (record-field-index type field)))
    (lambda (o . field?)
      (if (not (eq? (record-type o) (record-type type))) (error "record getter: record expected" type o)
          (if (pair? field?) field
              (struct-ref o i))))))

(define (record-setter type field)
  (let ((i (record-field-index type field)))
    (lambda (o v)
      (if (not (eq? (record-type o) (record-type type))) (error "record setter: record expected" type o)
          (struct-set! o i v)))))

(define (record-field-index type field)
  (+ 3 (or (lst-index (record-fields type) field)
           (error "no such field" type field))))

(define (lst-index lst o)
  (let loop ((lst lst) (i 0))
    (and (pair? lst)
         (if (eq? o (car lst)) i
             (loop (cdr lst) (1+ i))))))

;; (define-record-type <employee>
;;   (make-employee name age salary)
;;   employee?
;;   (name employe-name)
;;   (age employee-age set-employee-age!)
;;   (salary employee-salary))

;; (display <employee>)
;; (newline)

;; (display make-employee)
;; (newline)
;; (display "employee-age ")
;; (display employee-age)
;; (newline)

;; (display "set-employee-age! ")
;; (display set-employee-age!)
;; (newline)

;; (define janneke (make-employee "janneke" 49 42))
;; (display janneke)
;; (newline)

;; (display (employee-age janneke))
;; (newline)

;; (display (set-employee-age! janneke 33))
;; (newline)
;; (display (employee-age janneke))
;; (newline)