;;; -*-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-vector.mes - records, based on vector

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

(define (make-record-type type fields)
  (list->vector (list '*record-type* type fields (length fields))))

(define (record-type? o)
  (eq? (record-type o) '*record-type*))

(define (record-type o)
  (vector-ref o 0))

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

(define (record-constructor type params)
  (let ((fields (record-fields 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)))))
            (list->vector (cons type (append o rest))))))))

(define (record-fields o)
  (vector-ref o 2))

(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) type)) (error "record getter: record expected" type o)
          (if (pair? field?) field
              (vector-ref o i))))))

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

(define (record-field-index type field)
  (1+ (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)