#lang racket

(struct mbox ([v #:mutable]))

(define (box x) (mbox x))

(define (unbox x)
  (cond [(ip? x)
         (define imp? (vector-ref (ip-m x) 2))
         (define ub (vector-ref (ip-m x) 0))
         (define val (mbox-v x))
         (define res (ub x val))
         (unless (or imp? (chaperone-of? res val))
           (error 'fail))
         res]
        [else (mbox-v x)]))

(define (set-box! x v)
  (cond [(ip? x)
         (define imp? (vector-ref (ip-m x) 2))
         (define sb! (vector-ref (ip-m x) 1))
         (define val (sb! x v))
         (unless (or imp? (chaperone-of? val v))
           (error 'fail))
         (set-mbox-v! x val)]
        [else (set-mbox-v! x v)]))

(define (box? x) (mbox? x))

(define-values (ip ip? ip-m)
  (make-impersonator-property 'mbox-chaperone))

(define (chaperone-box b ub sb! . args)
  (apply chaperone-struct b set-mbox-v! (λ (a b) b) ip (vector ub sb! #f) args))
(define (impersonate-box b ub sb! . args)
  (apply impersonate-struct b set-mbox-v! (λ (a b) b) ip (vector ub sb! #t) args))

(provide box box? unbox set-box! chaperone-box impersonate-box)


(module+ test
  (require rackunit)
  (check-equal? (unbox (box 3)) 3)
  (check-equal? (unbox (chaperone-box (box 3) (λ (a b) b) (λ (a b) b))) 3)
  (check-equal? (unbox (impersonate-box (box 3) (λ (a b) b) (λ (a b) b))) 3)
  (check-equal? (unbox (impersonate-box (box 3)
                                        (λ (a b) 4)
                                        (λ (a b) b)))
                4)
  ;; this should error
  (check-exn exn:fail?
             (λ _ (unbox (chaperone-box (box 3)
                                        (λ (a b) 4)
                                        (λ (a b) b))))))