#lang scheme/base

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

(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?/first-order x)
  (and (pseudo-parameter? x)
       (let ([getter (pseudo-parameter-getter x)]
             [setter (pseudo-parameter-setter x)])
         (and (procedure? getter)
              (procedure-arity-includes? getter 0)
              (procedure? setter)
              (procedure-arity-includes? setter 1)))))

;; I had to copy this from collects/scheme/private/contract-guts.ss
;; because it isn't provided from scheme/contract.
(define (flat-proj ctc)
  (let ([pred? ((flat-get ctc) ctc)])
    (λ (pos neg src-info orig-str)
      (λ (val)
        (if (pred? val)
            val
            (raise-contract-error
             val
             src-info
             pos
             orig-str
             "expected <~a>, given: ~e"
             ((name-get ctc) ctc)
             val))))))

(define (pseudo-parameter/c c)
  (let ([c (coerce-contract pseudo-parameter/c c)])
    (make-proj-contract
     `(pseudo-parameter/c ,(contract-name c))
     (lambda (pos neg src-info name)
       (let* ([c-proj (if (flat-contract? c)
                          (flat-proj c)
                          ((proj-get c) c))]
              [pos-proj (c-proj pos neg src-info name)]
              [neg-proj (c-proj neg pos src-info name)])
           (lambda (p)
             (let ([getter (pseudo-parameter-getter p)]
                   [setter (pseudo-parameter-setter p)])
               (make-pseudo-parameter
                (lambda ()
                  (pos-proj (getter)))
                (lambda (x)
                  (setter (neg-proj x))))))))
     pseudo-parameter?/first-order)))

(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)))))]))