251 lines
11 KiB
Scheme
251 lines
11 KiB
Scheme
(module contracts-module-begin mzscheme
|
|
|
|
(require "contracts.ss")
|
|
|
|
(require-for-syntax (lib "list.ss")
|
|
(lib "boundmap.ss" "syntax"))
|
|
|
|
(provide beginner-module-begin intermediate-module-begin advanced-module-begin)
|
|
|
|
(define-syntaxes (beginner-module-begin intermediate-module-begin advanced-module-begin
|
|
beginner-continue intermediate-continue advanced-continue)
|
|
(let ()
|
|
(define (parse-contracts language-level-contract language-level-define-data
|
|
module-begin-continue-id)
|
|
;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to
|
|
;; a contract declaration. Syntax: (contract function-name (domain ... -> range))
|
|
(define extract-contracts
|
|
(lambda (lostx)
|
|
(filter contract-stx? lostx)))
|
|
|
|
; negate previous
|
|
(define extract-not-contracts
|
|
(lambda (stx-list)
|
|
(filter (lambda (x) (not (contract-stx? x))) stx-list)))
|
|
|
|
; predicate: is this syntax object a contract expr?
|
|
(define contract-stx?
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(contract function cnt)
|
|
(and (identifier? #'contract)
|
|
(module-identifier=? #'contract language-level-contract))]
|
|
[_ #f])))
|
|
|
|
; pred: is this syntax obj a define-data?
|
|
(define define-data-stx?
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(define-data name e1 e2 ...)
|
|
(and (identifier? #'define-data)
|
|
(module-identifier=? #'define-data language-level-define-data))]
|
|
[_ #f])))
|
|
|
|
;; takes a list of contract stx and a definitions stx and tells you if there is a contract defined for this function
|
|
(define contract-defined?
|
|
(lambda (cnt-list item)
|
|
(cond
|
|
[(null? cnt-list) #f]
|
|
[(fn=? (get-function-from-contract (car cnt-list)) (get-function-from-def item)) #t]
|
|
[else (contract-defined? (cdr cnt-list) item)])))
|
|
|
|
;; returns the name of the function in a given contract-syntax
|
|
(define get-function-from-contract
|
|
(lambda (stx)
|
|
(if (contract-stx? stx)
|
|
(syntax-case stx ()
|
|
[(contract function cnt ...) (syntax function)]
|
|
[_ (raise-syntax-error 'contract "internal error.1")])
|
|
(raise-syntax-error 'contract "this is not a valid contract" stx))))
|
|
|
|
;; used to match up contract definitions with function definitions
|
|
; should just be bound-identifier=?, but since beginner does some funny things
|
|
; with hygiene, we have to do this
|
|
(define (fn=? a b)
|
|
(string=? (symbol->string (syntax-object->datum a))
|
|
(symbol->string (syntax-object->datum b))))
|
|
|
|
;; search in the cnt-list for the contract that matches the given definition
|
|
(define get-contract
|
|
(lambda (cnt-list def-stx)
|
|
(cond
|
|
[(null? cnt-list) (error 'get-contract "contract not found")]
|
|
[(fn=? (get-function-from-contract (car cnt-list)) (get-function-from-def def-stx)) (car cnt-list)]
|
|
[else (get-contract (cdr cnt-list) def-stx)])))
|
|
|
|
;; returns the name of the function in a given definition-syntax
|
|
(define get-function-from-def
|
|
(lambda (stx)
|
|
(if (definition-stx? stx)
|
|
(syntax-case stx (begin define-values define-syntaxes)
|
|
[(define-values (f) e1 ...) (syntax f)]
|
|
[_ (raise-syntax-error 'contract "internal error.2")])
|
|
(raise-syntax-error 'defs "this is not a valid definition" stx))))
|
|
|
|
;; given a syntax object, tells you whether or not this is a definition.
|
|
(define definition-stx?
|
|
(lambda (stx)
|
|
(syntax-case stx (begin define-values)
|
|
[(define-values (f) e1 ...) #t]
|
|
[_ #f])))
|
|
|
|
;;transform-definiton
|
|
(define (transform-definition def)
|
|
(syntax-case def (define-values)
|
|
[(define-values (func) exp)
|
|
(with-syntax ([new-name (rename-func def)]
|
|
[expr-infname (syntax-property (syntax exp) 'inferred-name
|
|
(syntax-object->datum (syntax func)))])
|
|
(syntax/loc def (define-values (new-name) expr-infname)))]
|
|
[_ (raise-syntax-error 'contract "internal error.3")]))
|
|
|
|
(define (rename-func def)
|
|
(let ([name (get-function-from-def def)])
|
|
(syntax-case def (define-values)
|
|
[(define-values (f) e1)
|
|
(datum->syntax-object (syntax f)
|
|
(string->symbol (string-append (symbol->string (syntax-object->datum name)) "-con")))]
|
|
[_ (raise-syntax-error 'contract "internal error.4")])))
|
|
|
|
|
|
;; transform-contract : syntax syntax -> syntax
|
|
;; takes in two syntax objects: one representing a contract, and another representing a definition,
|
|
;; returns a syntax object that returns the correct language level contract wrapping
|
|
(define transform-contract
|
|
(lambda (language-level-contract cnt-stx def-stx)
|
|
(syntax-case cnt-stx ()
|
|
[(contract function cnt)
|
|
(with-syntax ([ll-contract language-level-contract]
|
|
[name-to-bind (get-function-from-def def-stx)]
|
|
[func-to-wrap (rename-func def-stx)])
|
|
(syntax/loc cnt-stx (ll-contract 'name-to-bind 'func-to-wrap cnt)))]
|
|
[_ (raise-syntax-error 'contract "internal error.5")])))
|
|
|
|
(define local-expand-stop-list
|
|
(list 'contract 'define-values 'define-syntaxes 'require 'require-for-syntax
|
|
'provide 'define-data '#%app '#%datum 'define-struct 'begin))
|
|
|
|
;; parse-contract-expressions
|
|
;; takes in a list of top level expressions and a list of contracts, and outputs the correct transformation.
|
|
;; 1. expand until we find a definition or a contract
|
|
;; 2. if its a definition, and it has a contract, transform and output
|
|
;; 3. else just output it
|
|
(define (parse-contract-expressions ll-contract ll-define-data contract-list expressions)
|
|
|
|
(let loop ([cnt-list contract-list]
|
|
[exprs expressions])
|
|
|
|
(cond
|
|
[(null? exprs)
|
|
(if (null? cnt-list)
|
|
(syntax (begin ))
|
|
(raise-syntax-error 'contracts "this contract has no corresponding def" (car cnt-list)))]
|
|
[else
|
|
(let ([expanded (car exprs)])
|
|
|
|
(syntax-case expanded (begin define-values define-data)
|
|
[(define-values (func) e1 ...)
|
|
(contract-defined? cnt-list expanded)
|
|
(let ([cnt (get-contract cnt-list expanded)])
|
|
(quasisyntax/loc (car exprs)
|
|
(begin
|
|
#,(transform-definition expanded)
|
|
#,(transform-contract ll-contract cnt expanded)
|
|
#,(loop (remove cnt cnt-list) (cdr exprs)))))]
|
|
[(define-data name c1 c2 ...)
|
|
(identifier? #'name)
|
|
(quasisyntax/loc (car exprs)
|
|
(begin
|
|
(#,ll-define-data name c1 c2 ...)
|
|
#,(loop cnt-list (cdr exprs))))]
|
|
[(begin e1 ...)
|
|
(loop cnt-list (append (syntax-e (syntax (e1 ...))) (cdr exprs)))]
|
|
[_else
|
|
(quasisyntax/loc (car exprs)
|
|
(begin
|
|
#,(car exprs)
|
|
#,(loop cnt-list (cdr exprs))))]))])))
|
|
|
|
;; contract transformations!
|
|
;; this is the macro, abstracted over which language level we are using.
|
|
;; parse-contracts :
|
|
;; given transformers that handle the actual contract parsing (depends on language level.. see contracts.scm and define-data.scm
|
|
;; this returns a big wrapper macro that translates calls to
|
|
;; (contract f (number -> number)) (define f ...)
|
|
;; ====>>>> (lang-lvl-contract f (number -> number) ...)
|
|
;; where ll-contract is either beginner-contract, intermediate-contract, or advanced-contract
|
|
;; and (define-data name ....) to (lang-lvl-define-data name ...)
|
|
|
|
(values
|
|
;; module-begin (for a specific language:)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ e1 ...)
|
|
;; module-begin-continue takes a sequence of expanded
|
|
;; exprs and a sequence of to-expand exprs; that way,
|
|
;; the module-expansion machinery can be used to handle
|
|
;; requires, etc.:
|
|
#`(#%plain-module-begin
|
|
(#,module-begin-continue-id () (e1 ...) ()))]))
|
|
|
|
;; module-continue (for a specific language:)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (e1 ...) () (defined-id ...))
|
|
;; Local-expanded all body elements, lifted out requires, etc.
|
|
;; Now process the result.
|
|
(begin
|
|
;; The expansion for contracts breaks the way that beginner-define, etc.,
|
|
;; check for duplicate definitions, so we have to re-check here.
|
|
;; A better strategy might be to turn every define into a define-syntax
|
|
;; to redirect the binding, and then the identifier-binding check in
|
|
;; beginner-define, etc. will work.
|
|
(let ([defined-ids (make-bound-identifier-mapping)])
|
|
(for-each (lambda (id)
|
|
(when (bound-identifier-mapping-get defined-ids id (lambda () #f))
|
|
(raise-syntax-error
|
|
#f
|
|
"this name was defined previously and cannot be re-defined"
|
|
id))
|
|
(bound-identifier-mapping-put! defined-ids id #t))
|
|
(reverse (syntax->list #'(defined-id ...)))))
|
|
;; Now handle contracts:
|
|
(let* ([top-level (reverse (syntax->list (syntax (e1 ...))))]
|
|
[cnt-list (extract-contracts top-level)]
|
|
[expr-list (extract-not-contracts top-level)])
|
|
(parse-contract-expressions language-level-contract
|
|
language-level-define-data
|
|
cnt-list
|
|
expr-list)))]
|
|
[(_ e1s (e2 . e3s) def-ids)
|
|
(let ([e2 (local-expand #'e2 'module local-expand-stop-list)])
|
|
;; Lift out certain forms to make them visible to the module
|
|
;; expander:
|
|
(syntax-case e2 (require define-syntaxes define-values-for-syntax define-values begin)
|
|
[(require . __)
|
|
#`(begin #,e2 (_ e1s e3s def-ids))]
|
|
[(define-syntaxes (id ...) . __)
|
|
#`(begin #,e2 (_ e1s e3s (id ... . def-ids)))]
|
|
[(define-values-for-syntax . __)
|
|
#`(begin #,e2 (_ e1s e3s def-ids))]
|
|
[(begin b1 ...)
|
|
#`(_ e1s (b1 ... . e3s) def-ids)]
|
|
[(define-values (id ...) . __)
|
|
#`(_ (#,e2 . e1s) e3s (id ... . def-ids))]
|
|
[else
|
|
#`(_ (#,e2 . e1s) e3s def-ids)]))]))))
|
|
|
|
(define-values (parse-beginner-contract/func continue-beginner-contract/func)
|
|
(parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue))
|
|
(define-values (parse-intermediate-contract/func continue-intermediate-contract/func)
|
|
(parse-contracts #'intermediate-contract #'intermediate-define-data #'intermediate-continue))
|
|
(define-values (parse-advanced-contract/func continue-advanced-contract/func)
|
|
(parse-contracts #'advanced-contract #'advanced-define-data #'advanced-continue))
|
|
|
|
(values parse-beginner-contract/func
|
|
parse-intermediate-contract/func
|
|
parse-advanced-contract/func
|
|
continue-beginner-contract/func
|
|
continue-intermediate-contract/func
|
|
continue-advanced-contract/func))))
|