;; Enumerated and finite types facility

;; Copyright (c) 2006 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; <dvanhorn@cs.brandeis.edu>

;; This is an implementation of the finite-types structure from Scheme 48.

(module finite-types mzscheme
  (provide define-enumerated-type define-finite-type)
  (require (lib "9.ss" "srfi"))
  
  (define-syntax define-enumerated-type
    (syntax-rules ()
      ((define-enumerated-type dispatcher type
         predicate instance-vector name-accessor index-accessor 
         (instance-name ...))
       (define-finite-type dispatcher type ()
         predicate instance-vector name-accessor index-accessor
         ((instance-name) ...)))))
  
  (define-syntax define-finite-type
    (syntax-rules ()
      ((define-finite-type dispatcher type field-tags
         predicate instance-vector name-accessor index-accessor
         field-clauses ... instances)
       (gen-names 
        #f
        (dispatcher type
                    field-tags
                    predicate instance-vector name-accessor index-accessor
                    field-clauses
                    ...)
        instances
        ()))))

  (define-syntax gen-names
    (syntax-rules ()
      ;; Generate fresh names for instances (reverses order).
      ((gen-names #f proto ((instance-name . fvs) . more) named-instances)
       (gen-names #f proto more ((%instance-name instance-name . fvs) . named-instances)))
      ;; Done naming, now re-reverse the instance clauses.
      ((gen-names #f proto () named-instances) 
       (gen-names #t proto () named-instances))
      ((gen-names #t proto ordered-instances (instance . more))
       (gen-names #t proto (instance . ordered-instances) more))
      ;; Done re-reversing.
      ((gen-names #t proto ordered-instances ())
       (define-finite-type* proto ordered-instances))))
      
  (define-syntax define-finite-type*
    (syntax-rules ()
      ((define-finite-type* 
         (dispatcher type
                     (field-tag-1 ...)
                     predicate instance-vector name-accessor index-accessor
                     (field-tag-2 accessor . ?modifier)
                     ...)
         ((%instance-name instance-name field-value ...) ...))
         
       (begin
         (define-record-type type (make-instance name field-tag-1 ...) predicate 
           (name name)
           (field-tag-2 accessor . ?modifier) ...)
         (define name-accessor name)
         (define %instance-name (make-instance 'instance-name field-value ...))
         ...
         (define-syntax dispatcher
           (syntax-rules (instance-name ...)
             ((dispatcher instance-name) %instance-name) ...))
         (define instance-vector (vector (dispatcher instance-name) ...))
         (define index-accessor
           (let ((instances (list %instance-name ...)))
             (lambda (instance)
               (let loop ((i 0) (instances instances))
                 (if (eq? instance (car instances)) i
                     (loop (+ i 1) (cdr instances)))))))))))

  ) ; end of finite-types module