; A simple procedural record interface from SLIB.

; TODO: rewrite in terms of rnrs records procedural (once that library
; is supported!).

(library (slib record)
  (export make-record-type record-constructor 
          record-predicate record-accessor record-modifier)
  (import (rnrs)
          (ubik define-values)
          (primitives make-struct-type
                      make-struct-field-accessor
                      make-struct-field-mutator
                      void andmap))

  ; Can't use MzScheme syntax:
  ;(define-struct record-type-descriptor
  ;  (name field-names mz-type mz-cons mz-pred mz-ref mz-set))
  
  (define-values (make-rtd rtd-name rtd-field-names
                           rtd-mz-type rtd-mz-cons rtd-mz-pred rtd-mz-ref rtd-mz-set)
    (call-with-values
     (lambda ()
       (make-struct-type 'record-descriptor #f 7 0))
     (lambda (record-type constructor record-type? accessor mutator)
       (values constructor
               (make-struct-field-accessor accessor 0 'rtd-name)
               (make-struct-field-accessor accessor 1 'rtd-field-names)
               (make-struct-field-accessor accessor 2 'rtd-mz-type)
               (make-struct-field-accessor accessor 3 'rtd-mz-cons)
               (make-struct-field-accessor accessor 4 'rtd-mz-pred)
               (make-struct-field-accessor accessor 5 'rtd-mz-ref)
               (make-struct-field-accessor accessor 6 'rtd-mz-set)))))
          
  (define make-record-type
    (lambda (type-name field-names)
      ;; Assert distinctness of field-names.
      (call-with-values
       (lambda ()
         (make-struct-type (string->symbol type-name) #f (length field-names) 0))
       (lambda (mz-type mz-cons mz-pred mz-ref mz-set)
         (make-rtd type-name field-names
                   mz-type mz-cons mz-pred mz-ref mz-set)))))
  
  (define record-constructor 
    (case-lambda 
      ((rtd) (rtd-mz-cons rtd))
      ((rtd field-names)
       (assert (distinct? field-names))
       (let ((rtd-field-names (rtd-field-names rtd)))
         (assert (andmap
                  (lambda (s) (memq s rtd-field-names))
                  field-names))
         (lambda args
           (assert (= (length args) (length field-names)))
           (let* ((r (apply (rtd-mz-cons rtd)
                            (map (lambda (_) (void)) rtd-field-names)))
                  (set-r (lambda (i v)
                           ((rtd-mz-set rtd) r i v))))
             
             (let loop ((args args) (field-names field-names))
               (if (null? args)
                   r
                   (begin
                     (set-r (field-index rtd (car field-names))
                            (car args))
                     (loop (cdr args) (cdr field-names)))))))))))
  
  (define record-predicate
    (lambda (rtd)
      (rtd-mz-pred rtd)))

  (define record-accessor 
    (lambda (rtd field-name)
      (assert (memq field-name (rtd-field-names rtd)))
      (let ((ref (rtd-mz-ref rtd))
            (i (field-index rtd field-name)))
        (lambda (x)
          (ref x i)))))
  
  (define record-modifier 
    (lambda (rtd field-name)
      (assert (memq field-name (rtd-field-names rtd)))
      (let ((set (rtd-mz-set rtd))
            (i (field-index rtd field-name)))
        (lambda (x v)
          (set x i v)))))
  
  (define (field-index rtd field-name)
    (- (length (rtd-field-names rtd))
       (length (memq field-name
                     (rtd-field-names rtd)))))
  
  (define (distinct? ls) ; list of symbols -> bool
    (or (null? ls)
        (and (not (memq (car ls) (cdr ls)))
             (distinct? (cdr ls)))))
 
;  (define :foo (make-record-type "foo" '(a b c)))
;  :foo
;  (define v1 ((record-constructor :foo) 1 2 3))
;  v1
;  ((record-accessor :foo 'a) v1)
;  ((record-accessor :foo 'b) v1)
;  ((record-accessor :foo 'c) v1)
;  (define v2 ((record-constructor :foo '(b c a)) 1 2 3))
;  v2
;  ((record-accessor :foo 'a) v2)
;  ((record-accessor :foo 'b) v2)
;  ((record-accessor :foo 'c) v2)
  
  ) ; end slib record