#lang scheme
;; 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.

(provide define-enumerated-type define-finite-type)
(require (lib "9.ss" "srfi")
         (lib "60.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 
      (dispatcher type field-tags
                  predicate instance-vector name-accessor index-accessor
                  field-clauses ...)
      instances))))

(define-syntax gen-names
  (syntax-rules ()
    ((gen-names proto instances)
     (gen-names proto instances () ()))
    ;; Generate fresh names for instances (reverses order).
    ((gen-names proto ((instance-name . fvs) . more) named n)
     (gen-names proto more 
                ((%instance-name (+ . n) instance-name . fvs) . named) 
                (1 . n)))
    ;; Done naming, now re-reverse the instance clauses.
    ((gen-names proto () named n) 
     (gen-names proto () named))
    ((gen-names proto ordered-instances (instance . more))
     (gen-names proto (instance . ordered-instances) more))
    ;; Done re-reversing.
    ((gen-names 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-id instance-name field-value ...) ...))
     (begin
       (define-record-type type (make-instance index field-tag-1 ...) 
         predicate 
         (index index)
         (field-tag-2 accessor . ?modifier) ...)
       (define %instance-name (make-instance instance-id field-value ...)) 
       ...
       (define-syntax dispatcher
         (syntax-rules (instance-name ...)
           ((dispatcher instance-name) %instance-name) ...))
       (define instance-vector (vector (dispatcher instance-name) ...))
       (define name-accessor 
         (let ((name-vector (apply vector '(instance-name ...))))
           (lambda (instance)
             (vector-ref name-vector (index instance)))))
       (define index-accessor index)))))