77 lines
3.3 KiB
Racket
77 lines
3.3 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base
|
|
racket/contract/private/helpers
|
|
racket/struct-info)
|
|
racket/contract/private/guts
|
|
racket/contract/private/misc)
|
|
|
|
(provide struct/c)
|
|
|
|
#|
|
|
as with copy-struct in struct.rkt, this first begin0
|
|
expansion "declares" that struct/c is an expression.
|
|
It prevents further expansion until the internal definition
|
|
context is sorted out.
|
|
|#
|
|
(define-syntax (struct/c stx)
|
|
(syntax-case stx ()
|
|
[(_ . args)
|
|
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
|
|
(syntax/loc stx (begin0 x)))]))
|
|
|
|
(define-syntax (do-struct/c stx)
|
|
(syntax-case stx ()
|
|
[(_ struct-name args ...)
|
|
(and (identifier? (syntax struct-name))
|
|
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
|
|
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
|
|
[(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
|
|
[(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
|
|
[(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
|
|
[(field-numbers ...)
|
|
(let loop ([i 0]
|
|
[l (syntax->list (syntax (args ...)))])
|
|
(cond
|
|
[(null? l) '()]
|
|
[else (cons i (loop (+ i 1) (cdr l)))]))]
|
|
[(type-desc-id
|
|
constructor-id
|
|
predicate-id
|
|
(rev-selector-id ...)
|
|
(mutator-id ...)
|
|
super-id)
|
|
(lookup-struct-info (syntax struct-name) stx)])
|
|
(unless (= (length (syntax->list (syntax (rev-selector-id ...))))
|
|
(length (syntax->list (syntax (args ...)))))
|
|
(raise-syntax-error 'struct/c
|
|
(format "expected ~a contracts because struct ~a has ~a fields"
|
|
(length (syntax->list (syntax (rev-selector-id ...))))
|
|
(syntax-e #'struct-name)
|
|
(length (syntax->list (syntax (rev-selector-id ...)))))
|
|
stx))
|
|
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
|
|
(syntax
|
|
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
|
|
|
|
(unless predicate-id
|
|
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
|
|
(unless (and selector-id ...)
|
|
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
|
|
|
|
(unless (flat-contract? ctc-x)
|
|
(error 'struct/c "expected flat contracts as arguments, got ~e" args))
|
|
...
|
|
|
|
(let ([ctc-pred-x (flat-contract-predicate ctc-x)]
|
|
...
|
|
[ctc-name-x (contract-name ctc-x)]
|
|
...)
|
|
(flat-named-contract
|
|
(build-compound-type-name 'struct/c 'struct-name ctc-x ...)
|
|
(λ (val)
|
|
(and (predicate-id val)
|
|
(ctc-pred-x (selector-id val)) ...))))))))]
|
|
[(_ struct-name anything ...)
|
|
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
|