136 lines
6.7 KiB
Scheme
136 lines
6.7 KiB
Scheme
(module tool-contract-language mzscheme
|
|
(provide (rename -#%module-begin #%module-begin)
|
|
(all-from-except mzscheme #%module-begin))
|
|
|
|
(require (lib "contract.ss"))
|
|
(require-for-syntax (lib "list.ss"))
|
|
|
|
(define-syntax (-#%module-begin stx)
|
|
|
|
(define-struct ctc-binding (var arg))
|
|
(define-struct def-binding (var arg))
|
|
|
|
(define (process-case case-stx)
|
|
(syntax-case case-stx (define)
|
|
[(define name expr)
|
|
(identifier? (syntax name))
|
|
(make-def-binding (syntax name) (syntax expr))]
|
|
[(name type type-names strs ...)
|
|
(and (identifier? (syntax name))
|
|
(not (string? (syntax-object->datum (syntax type))))
|
|
(andmap (λ (x) (string? (syntax-object->datum x))) (syntax->list (syntax (strs ...)))))
|
|
(make-ctc-binding (syntax name) (syntax type))]
|
|
[else (raise-syntax-error 'tool-contract-language.ss "unknown case" stx case-stx)]))
|
|
|
|
|
|
(syntax-case stx ()
|
|
[(_ cases ...)
|
|
(let* ([pcases (map process-case (syntax->list (syntax (cases ...))))]
|
|
[def-cases (filter def-binding? pcases)]
|
|
[ctc-cases (filter ctc-binding? pcases)])
|
|
(with-syntax ([(ctc-name ...) (map ctc-binding-var ctc-cases)]
|
|
[(ctc ...) (map ctc-binding-arg ctc-cases)]
|
|
[(def-name ...) (map def-binding-var def-cases)]
|
|
[(def-exp ...) (map def-binding-arg def-cases)]
|
|
[wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
|
|
(syntax/loc stx
|
|
(#%module-begin
|
|
(provide wrap-tool-inputs)
|
|
(define-syntax wrap-tool-inputs
|
|
(λ (in-stx)
|
|
(syntax-case in-stx ()
|
|
[(_ body tool-name)
|
|
(let ([f (λ (in-obj)
|
|
(datum->syntax-object
|
|
in-stx
|
|
(syntax-object->datum in-obj)
|
|
in-obj))])
|
|
(with-syntax ([(in-type (... ...)) (map f (syntax->list (syntax (ctc ...))))]
|
|
[(in-name (... ...)) (map f (syntax->list (syntax (ctc-name ...))))]
|
|
[(in-def-name (... ...)) (map f (syntax->list (syntax (def-name ...))))]
|
|
[(in-def-exp (... ...)) (map f (syntax->list (syntax (def-exp ...))))])
|
|
(syntax/loc in-stx
|
|
(let ([in-def-name in-def-exp] (... ...))
|
|
(let ([in-name (contract (let ([in-name in-type]) in-name)
|
|
in-name
|
|
'drscheme
|
|
tool-name
|
|
(quote-syntax in-name))] (... ...))
|
|
body)))))])))))))]
|
|
[(_ (name type type-names strs ...) ...)
|
|
(begin
|
|
(for-each
|
|
(λ (str-stx)
|
|
(when (string? (syntax-object->datum str-stx))
|
|
(raise-syntax-error 'tool-contract-language.ss "expected type name specification"
|
|
stx
|
|
str-stx)))
|
|
(syntax->list (syntax (type-names ...))))
|
|
(for-each
|
|
(λ (name)
|
|
(unless (identifier? name)
|
|
(raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
|
|
(syntax->list (syntax (name ...))))
|
|
(for-each
|
|
(λ (str)
|
|
(unless (string? (syntax-object->datum str))
|
|
(raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
|
|
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))]))
|
|
|
|
(define-syntax (-#%module-begin2 stx)
|
|
(syntax-case stx ()
|
|
[(_ (name type type-names strs ...) ...)
|
|
(and (andmap identifier? (syntax->list (syntax (name ...))))
|
|
(andmap (λ (x) (not (string? (syntax-object->datum x))))
|
|
(syntax->list (syntax (type-names ...))))
|
|
(andmap (λ (x) (string? (syntax-object->datum x)))
|
|
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))
|
|
(with-syntax ([wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
|
|
(syntax/loc stx
|
|
(#%module-begin
|
|
(provide wrap-tool-inputs)
|
|
(define-syntax wrap-tool-inputs
|
|
(λ (in-stx)
|
|
(syntax-case in-stx ()
|
|
[(_ body tool-name)
|
|
(with-syntax ([(in-type (... ...))
|
|
(map (λ (in-type-obj)
|
|
(datum->syntax-object
|
|
in-stx
|
|
(syntax-object->datum in-type-obj)
|
|
in-type-obj))
|
|
(syntax->list (syntax (type ...))))]
|
|
[(in-name (... ...))
|
|
(map (λ (in-name-obj)
|
|
(datum->syntax-object
|
|
in-stx
|
|
(syntax-object->datum in-name-obj)
|
|
in-name-obj))
|
|
(syntax->list (syntax (name ...))))])
|
|
(syntax/loc in-stx
|
|
(let ([in-name (contract (let ([in-name in-type]) in-name)
|
|
in-name
|
|
'drscheme
|
|
tool-name
|
|
(quote-syntax in-name))] (... ...))
|
|
body)))]))))))]
|
|
[(_ (name type type-names strs ...) ...)
|
|
(begin
|
|
(for-each
|
|
(λ (str-stx)
|
|
(when (string? (syntax-object->datum str-stx))
|
|
(raise-syntax-error 'tool-contract-language.ss "expected type name specification"
|
|
stx
|
|
str-stx)))
|
|
(syntax->list (syntax (type-names ...))))
|
|
(for-each
|
|
(λ (name)
|
|
(unless (identifier? name)
|
|
(raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
|
|
(syntax->list (syntax (name ...))))
|
|
(for-each
|
|
(λ (str)
|
|
(unless (string? (syntax-object->datum str))
|
|
(raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
|
|
(apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))])))
|