#lang scheme

(require (for-syntax scheme/base)
         (for-syntax syntax/struct))

(provide pseudo-parameter? make-pseudo-parameter pseudo-parameter/c define-parameter-set)

(define-struct pseudo-parameter (getter setter)
  #:property prop:procedure (case-lambda
                              [(pp) ((pseudo-parameter-getter pp))]
                              [(pp x) ((pseudo-parameter-setter pp) x)]))

(define (pseudo-parameter/c c)
  (and/c pseudo-parameter?
         (case-> (-> c)
                 (c . -> . any))))

(define-syntax (define-parameter-set stx)
  (syntax-case stx ()
    [(define-parameter-set struct current (param default . maybe-guard) ...)
     (with-syntax ([(struct:pset make-pset pset? get-field ...)
                    (build-struct-names #'struct (syntax->list #'(param ...)) #f #t stx)])
       #'(begin
           (define param (make-parameter default . maybe-guard)) ...
           (define-struct struct (param ...) #:prefab)
           (define current
             (make-pseudo-parameter
              (lambda ()
                (make-pset (param) ...))
              (lambda (x)
                (unless (pset? x)
                  (error 'current "expected a parameter set of type ~a, received: ~v" 'struct x))
                (param (get-field x)) ...
                x)))))]))