#| Module records by Jacob J. A. Koot

Defines a language with all of mzscheme except for the following mods and adds:

procedure (make-record-type type-name super-record-constr list-of-field-names) --> record-constr record-pred (*)
procedure (record-constr field-value ...) --> record
procedure (record)                        --> (record-constr super-record-constr record-pred ((field-name . field-value) ...)) (**)
procedure (record field-name)             --> field-value
procedure (record field-name field-value) --> void; stores the field-value in field field-name
procedure (record-pred object)            --> #t if the object is a record of (a derived type of) the corresponding record-type, else #f.

(*)  If the super-record-constr is not #f, it must be a record-constr and the new record type inherits all field-names of the super-record-type, to which the new field-names are added. All field-names, both new ones and inherited ones, must be distinct.
(**) The assoc-list (field-name . field-value) ...) is shared with the record, it is not a copy.

procedure (record-constr? object)         --> #t if the object is a record-constr, else #f.
procedure (record? object)                --> #t if the object is a record, else #f.
procedure (copy-record record)            --> copy of the record
procedure (constr-info record-constr)     --> (super-record-constr record-pred (field-name ...))

syntax (define-record-types ((constr-id pred-id) (type-name super (field-name ...))) ...)
                                          ==> (begin (define-values (constr-id pred-id) (make-record-type 'type-name super '(field-name ...))) ...)
syntax (letrec-record-types (((constr-id pred-id) (type-name super (field-name ...))) ...) . body)
                                          ==> (letrec-values (((constr pred) (make-record-type 'type-name super '(field-name ...))) ...) . body)
syntax (define-records (r (c . arg)) ...) ==> (define-values (r ...) (values (c . arg) ...))
syntax (letrec-records ((r (c . arg)) ...) . body)
                                          ==> (letrec-values (((r ...) (values (c . arg) ...))) . body)
syntax (#%top . identifier)               --> current value of the top level variable identified by the identifier. Error if not defined.
syntax (#%top . field-ref)                --> value of the field
syntax (set! identifier value)            --> void ; the value is stored in the variable identified by the identifier
syntax (set! field-ref  value)            --> void ; the value is stored in the field

type-name             : symbol
super-record-constr   : record-constr or #f
field-name            : symbol
field-ref             : identifier.field-name | field-ref.field-name
identifier            : as in MzScheme, but must not contain periods in order to prevent confusion between identifiers and field-refs

field-ref a.b         : refers to field b of the record supposed to be present in variable a.
field-ref field-ref.b : refers to field b of the record supposed to be present in the field referred to by the field-ref.

Example:
(define-values (make-person person?) (make-record-type 'person #f '(name maried-with children)))
(define jacob (make-person 'jacob #f ()))
(define maria (make-person 'maria #f ()))
(define (mary man woman)
 (set! man.maried-with woman)
 (set! woman.maried-with man))
(define (birth mother father name)
 (let ((child (make-person name #f ())))
  (set! mother.children (cons child mother.children))
  (set! father.children (cons child father.children))))
(define (names-of-children person) (map (lambda (child) child.name) person.children))
(mary jacob maria)
(birth maria jacob 'son)
(birth maria jacob 'doughter)
(names-of-children maria) ; --> (doughter son)

|#

(module records mzscheme

 (define-values (make-constr record-constr?)
  (let-values (((descr constr pred acc mut) (make-struct-type 'constr #f 1 0 #f () #f 0)))
   (values constr pred)))
 
 (define-values (top-record-constr record?)
  (let-values (((descr constr pred acc mut) (make-struct-type 'record #f 1 0 #f () #f 0)))
   (values (make-constr (lambda (tag) (list descr constr pred #f ()))) pred)))
 
 (define (make-record-type name super field-names)
  (if (not (symbol? name)) (error 'make-record-type "name must be a symbol, given: ~s" name))
  (if (and super (not (record-constr? super))) (error 'make-record-type "super must be a record-constr, given: ~s" super))
  (if (not (and (list? field-names) (andmap symbol? field-names)))
   (error 'make-record-type "all field-names must be symbols, given: ~s" field-names))
  (let-values
   (((super-descr super-constr super-pred super-record-constr super-field-names)
     (apply values ((or super top-record-constr) info-tag))))
   (let-values (((descr constr pred acc mut) (make-struct-type name super-descr 0 0 #f () #f #f)))
    (let ((field-names (checked-append super-field-names field-names)))
     (values (make-constr-proc descr constr pred super field-names) pred)))))
 
 (define (copy-record record)
  (if (not (record? record)) (error 'copy-record "record expected, given: ~s" record))
  (let-values (((record-constr super-recor-constr pred assoc-list) (apply values (record))))
   (apply record-constr (map cdr assoc-list))))
 
 (define (constr-info constr)
  (if (not (record-constr? constr)) (error 'constr-info "constr expected, given: ~s" constr))
  (let-values (((descr constr pred super-record-constr field-names) (apply values (constr info-tag))))
   (list super-record-constr pred field-names)))
 
 (define-for-syntax (make-accessor stx id)
  (define (error) (raise-syntax-error 'module-dot "incorrect field-ref" stx id))
  (datum->syntax-object stx
   (let loop ((tail ()) (head (reverse (string->list (symbol->string (syntax-e id))))))
    (cond
     ((null? head) (if (null? tail) (error) (string->symbol (list->string tail))))
     ((char=? (car head) #\.) (if (null? tail) (error) `(,(loop () (cdr head))  ',(string->symbol (list->string tail)))))
     (else (loop (cons (car head) tail) (cdr head)))))))
 
 (define-syntax (top stx)
  (syntax-case stx ()
   ((top . id)
    (let ((accessor (make-accessor stx #'id)))
     (if (identifier? accessor) #'(#%top . id) accessor)))))
      
 (define-syntax (*set! stx)
  (syntax-case stx ()
   ((*set! id val)
    (let ((accessor (make-accessor stx #'id)))
     (if (identifier? accessor) #'(set! id val) #`(#,@accessor val))))))
 
 (define-syntax (define-record-types stx)
  (syntax-case stx ()
   ((define-record-types ((constr pred) (name super (field-name ...))) ...)
  #'(begin (define-values (constr pred) (make-record-type 'name super '(field-name ...))) ...))))
 
 (define-syntax (letrec-record-types stx)
  (syntax-case stx ()
   ((letrec-record-types (((constr pred) (name super (field-name ...))) ...) . body)
  #'(letrec-values (((constr pred) (make-record-type 'name super '(field-name ...))) ...) . body))))
 
 (define-syntax (define-records stx)
  (syntax-case stx ()
   ((define-records (r (c . arg)) ...)
  #'(define-values (r ...) (values (c . arg) ...)))))
 
 (define-syntax (letrec-records stx)
  (syntax-case stx ()
   ((letrec-records ((r (c . arg)) ...) . body)
  #'(letrec-values (((r ...) (values (c . arg) ...))) . body))))

 (define (make-constr-proc descr constr pred super-record-constr field-names)
  (letrec
   ((record-constr
     (make-constr
      (case-lambda
       ((field-value) (if (info-tag? field-value) constr-info (constr (make-record-proc record-constr constr-info (list field-value)))))
       (field-values (constr (make-record-proc record-constr constr-info field-values))))))
     (constr-info (list descr constr pred super-record-constr field-names)))
   record-constr))
 
 (define (make-record-proc record-constr constr-info field-values)
  (let-values (((descr constr pred super-record-constr field-names) (apply values constr-info)))
   (let ((assoc-list (map cons field-names field-values)))
    (let ((record-info (list descr constr pred field-names record-constr super-record-constr assoc-list)))
     (case-lambda
      (() (list record-constr super-record-constr pred assoc-list))
      ((field-name) (cdr (checked-assq field-name assoc-list)))
      ((field-name field-value) (set-cdr! (checked-assq field-name assoc-list) field-value)))))))
 
 (define (checked-append . x)
  (let ((x (apply append x)))
   (let loop ((y x))
    (if (null? y) x
     (let ((kar (car y)) (kdr (cdr y)))
      (if (memq kar kdr) (error 'make-record-type "duplicate field-name ~s" kar) (loop kdr)))))))
 
 (define (checked-assq s assoc-list) (or (assq s assoc-list) (error 'records "field-ref/assignment to unknown field ~a." s)))
 (define-values (info-tag info-tag?) (let-struct info-tag () (values (make-info-tag) info-tag?)))
 
 (provide
  (all-from-except mzscheme #%top set!)
  (rename top #%top)
  (rename *set! set!)
  make-record-type
  record? record-constr?
  copy-record constr-info
  define-record-types letrec-record-types
  define-records letrec-records))