; Module records by Jacob J. A. Koot

(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 allow-starting-dot)
  (define (error) (raise-syntax-error 'module-dot "incorrect field-ref" stx id))
  (define (symbol->list x) (string->list (symbol->string x)))
  (define (list->symbol x) (string->symbol (list->string x)))
  (define (symbol->symbol x) (list->symbol (symbol->list x)))
  (define (parse-field-ref tail head)
   (cond
    ((null? head) (if (null? tail) (error) (list->symbol tail)))
    ((char=? (car head) #\.) (if (null? tail) (error) `(,(parse-field-ref () (cdr head))  ',(list->symbol tail))))
    (else (parse-field-ref (cons (car head) tail) (cdr head)))))
  (datum->syntax-object stx 
   (let ((lst (symbol->list (syntax-e id))))
    (cond
      ((null? lst) (error))
      ((and allow-starting-dot (char=? (car lst) #\.))
       (let ((sym (gensym 'sym)))
       `(,#'lambda (,(symbol->symbol sym)) ,(parse-field-ref () (reverse (append (symbol->list sym) lst))))))
      (else (parse-field-ref () (reverse lst)))))))
 
 (define-syntax (top stx)
  (syntax-case stx ()
   ((top . id)
    (let ((accessor (make-accessor stx #'id #t)))
     (if (identifier? accessor) #'(#%top . id) accessor)))))
      
 (define-syntax (*set! stx)
  (syntax-case stx ()
   ((*set! id val)
    (let ((accessor (make-accessor stx #'id #f)))
     (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)))
   (if (not (= (length field-values) (length field-names)))
    (error 'record-constr "incorrect nr of field-values. Field-names are ~s. Field-values given: ~s." field-names field-values))
   (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 (copy-assoc-list 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 (copy-assoc-list assoc-list) (map copy-entry assoc-list))
 (define (copy-entry entry) (cons (car entry) (cdr entry)))
 (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))