75 lines
3.0 KiB
Racket
75 lines
3.0 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base
|
|
racket/syntax
|
|
syntax/parse
|
|
racket/provide-transform
|
|
syntax/define)
|
|
racket/contract)
|
|
|
|
(provide define/latent-contract activate-contract-out)
|
|
|
|
(begin-for-syntax
|
|
(struct value/latent-contract (value contract)
|
|
#:property prop:procedure
|
|
(λ (v/lc stx)
|
|
(define value (value/latent-contract-value v/lc))
|
|
(syntax-case stx ()
|
|
[(_ . args) (quasisyntax/loc stx (#,value . args))]
|
|
[_ (quasisyntax/loc stx #,value)]))))
|
|
|
|
(define-syntax (define/latent-contract stx)
|
|
(syntax-parse stx
|
|
[(_ (head . args) contract:expr body:expr ...+)
|
|
(define-values (name value)
|
|
(normalize-definition (syntax/loc stx (define (head . args) body ...)) #'lambda #t #t))
|
|
(syntax-protect
|
|
(quasisyntax/loc stx
|
|
(define/latent-contract #,name contract #,value)))]
|
|
[(_ name:id contract:expr value:expr)
|
|
(with-syntax ([value-name (format-id #f "~a" #'name)]
|
|
[contract-name (format-id #f "~a-contract" #'name)])
|
|
(syntax-protect
|
|
(syntax/loc stx
|
|
(begin (define value-name value)
|
|
(define contract-name contract)
|
|
(define-syntax name
|
|
(value/latent-contract #'value-name #'contract-name))))))]))
|
|
|
|
(define-for-syntax (activate->contract-out stx id)
|
|
(let* ([err (λ () (raise-syntax-error 'activate-contract-out "no latent contract" id))]
|
|
[v/lc (syntax-local-value id err)])
|
|
(when (not (value/latent-contract? v/lc)) (err))
|
|
(with-syntax ([contract (value/latent-contract-contract v/lc)])
|
|
(quasisyntax/loc stx [#,id contract]))))
|
|
|
|
(define-syntax activate-contract-out/end
|
|
(make-provide-pre-transformer
|
|
(λ (stx phases)
|
|
(syntax-case stx ()
|
|
[(_ id ...) (with-syntax ([(item ...) (for/list ([id (in-list (syntax->list #'(id ...)))])
|
|
(activate->contract-out stx id))])
|
|
(pre-expand-export
|
|
(syntax-protect
|
|
(syntax/loc stx (contract-out item ...)))
|
|
phases))]))))
|
|
|
|
(define-for-syntax (phases->abs-phases phases)
|
|
(map (λ (phase) (and phase (+ phase (syntax-local-phase-level))))
|
|
(if (null? phases) '(0) phases)))
|
|
|
|
(define-for-syntax (make-lifting-provide-pre-transformer target-id)
|
|
(make-provide-pre-transformer
|
|
(λ (stx phases)
|
|
(syntax-case stx ()
|
|
[(_ args ...) (let ()
|
|
(for ([phase (in-list (phases->abs-phases phases))])
|
|
(syntax-local-lift-module-end-declaration
|
|
(syntax-protect
|
|
(quasisyntax/loc stx
|
|
(provide (for-meta #,phase (#,target-id args ...)))))))
|
|
(syntax/loc stx (combine-out)))]))))
|
|
|
|
(define-syntax activate-contract-out
|
|
(make-lifting-provide-pre-transformer #'activate-contract-out/end))
|