#lang racket/base

(provide current-struct-mappers
	 install-struct-mapper!
	 struct-map
	 struct-map/accumulator)

;; Parameter<Hash<StructType,Mapper>>
(define current-struct-mappers (make-parameter (hash)))

;; StructType Mapper -> Void
(define (install-struct-mapper! struct-type m)
  (current-struct-mappers (hash-set (current-struct-mappers) struct-type m)))

;; (X -> Y) Struct<X> -> Struct<Y>
(define (struct-map f x)
  (define-values (result acc)
    (struct-map* 'struct-map (lambda (v acc) (values (f v) acc)) (void) x))
  result)

;; (X Seed -> Y Seed) Seed Struct<X> -> Struct<Y> Seed
(define (struct-map/accumulator f seed x)
  (struct-map* 'struct-map/accumulator f seed x))

(define (struct-map* name f seed x)
  (define-values (i skipped) (struct-info x))
  (when (not i) (error name "Cannot retrieve struct-info for ~v" x))
  (define m (hash-ref (current-struct-mappers)
		      i
		      (lambda ()
			(define key (prefab-struct-key x))
			(when (not key) (error name "No mapper for ~v" x))
			(prefab-struct-mapper key))))
  (m f seed x))

(define ((prefab-struct-mapper key) f initial-seed x)
  (define-values (new-fields final-seed)
    (for/fold ([new-fields '()] [old-seed initial-seed])
	([old-field (cdr (vector->list (struct->vector x)))])
      (define-values (new-field new-seed) (f old-field old-seed))
      (values (cons new-field new-fields) new-seed)))
  (values (apply make-prefab-struct key (reverse new-fields)) final-seed))