#lang scheme
(define affine-procedure/c
(make-proj-contract
'affine-procedure/c
(lambda (pos neg src name)
(lambda (f)
(if (procedure? f)
(let ([blessed #t])
(make-keyword-procedure
(lambda (keys vals . args)
(if blessed
(begin
(set! blessed #f)
(keyword-apply f keys vals args))
(raise-contract-error
f
src
neg
name
"affine function applied more than once")))))
(raise-contract-error
f
src
pos
name
"expected affine procedure, given: ~e"
f))))
procedure?))
(define-syntax -o
(syntax-rules ()
[(-o ARGS ...) (and/c (-> ARGS ...) affine-procedure/c)]))
(define-syntax -o*
(syntax-rules ()
[(-o* ARGS ...) (and/c (->* ARGS ...) affine-procedure/c)]))
(define-struct affine-box (unbox))
(define (affine-box* val)
(make-affine-box (lambda () val)))
(define (affine-unbox ab)
((affine-box-unbox ab)))
(define (affine-box/c c)
(let ([ctc (coerce-contract 'affine-box/c c)])
(make-proj-contract
(build-compound-type-name 'affine-box/c c)
(lambda (pos neg src name)
(lambda (ab)
(if (affine-box? ab)
(let ([blessed #t])
(make-affine-box
(lambda ()
(if blessed
(begin
(set! blessed #f)
((((proj-get ctc) ctc) pos neg src name)
((affine-box-unbox ab))))
(raise-contract-error
ab
src
neg
name
"affine box unboxed more than once")))))
(raise-contract-error
ab
src
pos
name
"expected affine box, given: ~e"
ab))))
affine-box?)))
(provide/contract
[affine-procedure/c contract?]
[affine-box/c (contract? . -> . contract?)]
[affine-box? (any/c . -> . boolean?)]
[rename affine-box*
affine-box (any/c . -> . affine-box?)]
[affine-unbox (affine-box? . -> . any/c)])
(provide -o -o*)