(module make-hash-struct mzscheme
  (require (lib "etc.ss"))
  (require-for-syntax (lib "etc.ss"))
  
  ;; TODO: statically pull in some of this information (like arity) from the
  ;; structure type descriptor to provide a nicer interface.
  
  (define-for-syntax (generate-n-temporaries n)
    (generate-temporaries
     (datum->syntax-object #f (build-list n (lambda (i) 'tmp)))))
  
  (provide make-hash-struct)
  ;; make-hash-struct: (X1 X2 ... -> Y)
  ;;                   literal-number
  ;;                   (X1 X2 ...)
  ;;                   ((Y X1 -> void) (Y X2 -> void) ...)
  ;;                   -> (X1 X2 ... -> Y)
  ;;
  ;; SYNTAX: creates a constructor that "hash-cons"es its input based on equal?
  (define-syntax (make-hash-struct stx)
    (syntax-case stx ()
      [(_ constructor-expr arity initial-vals-exprs mutators-exprs)
       
       (begin
         (unless (number? (syntax-e #'arity))
           (raise-syntax-error
            #f "not a literal number" stx #'arity))
         (unless (= (length (syntax->list #'initial-vals-exprs))
                    (syntax-e #'arity))
           (raise-syntax-error
            #f "number of initial values must match arity" stx #'initial-vals-exprs))
         (unless (= (length (syntax->list #'mutators-exprs))
                    (syntax-e #'arity))
           (raise-syntax-error
            #f "number of mutators must match arity" stx #'mutators-exprs))
         
         (with-syntax ([(args-1 ...)
                        (generate-n-temporaries (syntax-e #'arity))]
                       [(args-2 ...)
                        (generate-n-temporaries (syntax-e #'arity))]
                       [(args ...)
                        (generate-n-temporaries (syntax-e #'arity))]
                       
                       [(initial-vals-exprs ...) #'initial-vals-exprs]
                       [(mutators-exprs ...) #'mutators-exprs]
                       
                       [(initial-vals ...)
                        (generate-n-temporaries
                         (length (syntax->list #'initial-vals-exprs)))]
                       [(mutators ...)
                        (generate-n-temporaries
                         (length (syntax->list #'mutators-exprs)))])
           (syntax/loc stx
             (local
                 ((define constructor constructor-expr)
                  (define-values (initial-vals ... mutators ...)
                    (values initial-vals-exprs ...
                            mutators-exprs ...))
                  
                  (define the-elt (constructor initial-vals ...))
                  (define ht (make-hash-table 'weak 'equal))
                  
                  (define (initialize-the-elt! args-1 ...)
                    (mutators the-elt args-1) ...)
                  
                  (define (add-to-hash&get! args-2 ...)
                    (let ([new-elt (constructor args-2 ...)])
                      (hash-table-put! ht new-elt (make-ephemeron new-elt (box new-elt)))
                      new-elt)))
               
               (lambda (args ...)
                 (initialize-the-elt! args ...)
                 (let ([v (hash-table-get ht the-elt #f)])
                   (initialize-the-elt! initial-vals ...)
                   (cond
                     [v
                      (let ([v (ephemeron-value v)])
                        (cond
                          [v (unbox v)]
                          [else
                           (add-to-hash&get! args ...)]))]
                     [else
                      (add-to-hash&get! args ...)])))))))]
      
      [else
       (raise-syntax-error #f "needs arity, initial values, and mutators" stx)])))