203 lines
8.8 KiB
Scheme
203 lines
8.8 KiB
Scheme
(module contract-transformers mzscheme
|
|
(require-for-template mzscheme
|
|
"contracts-helpers.ss"
|
|
"beginner-contracts.ss"
|
|
"intermediate-contracts.ss"
|
|
"advanced-contracts.ss")
|
|
|
|
(provide (all-defined))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; COMMON STUFF- Translators
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; We really should compare with module-identifier=",
|
|
;; but importing the right identifiers here is a pain.
|
|
;; As it happens, the teaching languages disable shadowing,
|
|
;; so we can safely use symbol equality.
|
|
(define (contract-id=? a b)
|
|
(eq? (syntax-e a) (syntax-e b)))
|
|
|
|
;; a translator is a function that translates syntax for contracts
|
|
;; (like: number, (number -> string), (number -> (number -> boolean)) )
|
|
;; and converts it into the necesary function calls to enforce those contracts
|
|
|
|
;; translate-arrow-contract : syntax (syntax -> syntax) -> syntax
|
|
;; parses contracts for (domain ... -> range) type contracts
|
|
;; the first argument is the syntax object to parse
|
|
;; the second argument is translator that should be used for recursive calls
|
|
(define translate-arrow-contract
|
|
(lambda (stx translator)
|
|
(syntax-case stx (->)
|
|
[(domain ... -> range)
|
|
(with-syntax
|
|
([(parsed-domain ...) (map translator (syntax-e (syntax (domain ...))))]
|
|
[parsed-range (translator (syntax range))]
|
|
[ret stx])
|
|
(syntax (->-contract (list parsed-domain ...) parsed-range #'ret)))]
|
|
[else-stx (raise-syntax-error 'contracts "unknown contract" (syntax else-stx))])))
|
|
|
|
;; beginners cant use higher order contracts, so only allow func contracts in the top level
|
|
(define beginner-translate-contract
|
|
(case-lambda
|
|
[(stx) (beginner-translate-contract stx beginner-translate-flat-contract)]
|
|
[(stx recur)
|
|
(syntax-case stx (->)
|
|
[(domain ... -> range) (translate-arrow-contract stx recur)]
|
|
[_else-stx (beginner-translate-flat-contract stx recur)])]))
|
|
|
|
|
|
;; syntax definitions for beginner language contracts (from beginner-contracts.scm)
|
|
(define beginner-translate-flat-contract
|
|
(case-lambda
|
|
[(stx) (beginner-translate-flat-contract stx beginner-translate-flat-contract)]
|
|
[(stx recur)
|
|
|
|
(syntax-case* stx (-> add1 quote cons number any integer
|
|
exact-number inexact-number posn boolean
|
|
true false
|
|
string empty symbol list)
|
|
contract-id=?
|
|
[(cons a b) (with-syntax ([car-contract (recur (syntax a))]
|
|
[cdr-contract (recur (syntax b))]
|
|
[ret stx])
|
|
(syntax/loc stx (cons-contract car-contract cdr-contract #'ret)))]
|
|
[(list a ...) (with-syntax ([(translated ...) (map recur (syntax-e (syntax/loc stx (a ...))))]
|
|
[ret stx])
|
|
(syntax/loc stx (args-contract (list translated ...) #'ret)))]
|
|
[(add1 a) (with-syntax ([translated (recur (syntax/loc stx a))]
|
|
[ret stx])
|
|
(syntax/loc stx (add1-contract translated #'ret)))]
|
|
[empty (with-syntax ([ret stx])
|
|
(syntax/loc stx (empty-contract #'ret)))]
|
|
[(quote n) (with-syntax ([ret stx])
|
|
(syntax/loc stx (build-flat-contract (lambda (x) (eq? x 'n)) 'n #'ret)))]
|
|
[number (with-syntax ([ret stx])
|
|
(syntax/loc stx (number-contract #'ret)))]
|
|
[any (with-syntax ([ret stx])
|
|
(syntax/loc stx (any-contract #'ret)))]
|
|
[symbol (with-syntax ([ret stx])
|
|
(syntax/loc stx (symbol-contract #'ret)))]
|
|
[integer (with-syntax ([ret stx])
|
|
(syntax/loc stx (integer-contract #'ret)))]
|
|
[exact-number (with-syntax ([ret stx])
|
|
(syntax/loc stx (exact-number-contract #'ret)))]
|
|
[inexact-number (with-syntax ([ret stx])
|
|
(syntax/loc stx (inexact-number-contract #'ret)))]
|
|
[boolean (with-syntax ([ret stx])
|
|
(syntax/loc stx (boolean-contract #'ret)))]
|
|
[true (with-syntax ([ret stx])
|
|
(syntax/loc stx (true-contract #'ret)))]
|
|
[false (with-syntax ([ret stx])
|
|
(syntax/loc stx (false-contract #'ret)))]
|
|
[string(with-syntax ([ret stx])
|
|
(syntax/loc stx (string-contract #'ret)))]
|
|
[posn (with-syntax ([ret stx])
|
|
(syntax/loc stx (posn-contract #'ret)))]
|
|
[(domain ... -> range)
|
|
(raise-syntax-error 'contracts "functions in the beginner language can't take other functions as input" stx)]
|
|
[(make-struct e1 e2 ...)
|
|
(pair? (regexp-match "make-(.*)" (symbol->string (syntax-object->datum (syntax make-struct)))))
|
|
(let ([make (regexp-match "make-(.*)" (symbol->string (syntax-object->datum (syntax make-struct))))])
|
|
(let ([struct (datum->syntax-object stx (string->symbol (cadr make)))])
|
|
(if (define-struct? struct)
|
|
(with-syntax ([pred (get-predicate-from-struct struct)]
|
|
[(accessors ...) (reverse (get-accessors-from-struct struct))]
|
|
[name (syntax-object->datum struct)]
|
|
[(translated ...) (map recur (syntax-e (syntax (e1 e2 ...))))]
|
|
[ret stx]) ; we wrap with lambdas so that beginner doesnt complain about using them without a (
|
|
(syntax/loc stx (struct-contract 'name (lambda (x) (pred x)) (list (lambda (x) (accessors x)) ...) (list translated ...) #'ret)))
|
|
(raise-syntax-error 'contracts (format "unknown structure type: ~e"
|
|
(syntax-object->datum struct)) stx))))]
|
|
|
|
[-> (raise-syntax-error 'contracts "found a lone '->', check your parentheses!" stx)]
|
|
|
|
[name
|
|
(number? (syntax-object->datum (syntax name)))
|
|
(with-syntax ([num (syntax-object->datum (syntax name))]
|
|
[ret stx])
|
|
(syntax/loc stx (build-flat-contract (lambda (x) (eq? num x)) num #'ret)))]
|
|
|
|
[name
|
|
(define-data? (syntax name)) ; things from a define data
|
|
(with-syntax ([cnt (get-cnt-from-dd (syntax name))])
|
|
(syntax/loc stx cnt))]
|
|
|
|
[name
|
|
(define-struct? (syntax name)) ; generic structs
|
|
(with-syntax ([pred (get-predicate-from-struct (syntax name))]
|
|
[type-name (get-name-from-struct (syntax name))]
|
|
[ret stx])
|
|
(syntax/loc stx (build-flat-contract (lambda (x) (pred x)) 'type-name #'ret)))]
|
|
|
|
[name (raise-syntax-error 'contracts "unknown contract" (syntax name))])]))
|
|
|
|
;; stx definitions for intermediate language contracts (intermediate-contracts.scm)
|
|
(define intermediate-translate-contract
|
|
(case-lambda
|
|
[(stx) (intermediate-translate-contract stx intermediate-translate-contract)]
|
|
[(stx recur)
|
|
(syntax-case* stx (-> listof quote vectorof boxof)
|
|
contract-id=?
|
|
[(listof type) (with-syntax ([ret stx]
|
|
[trans-type (recur (syntax type))])
|
|
(syntax/loc stx (listof-contract trans-type #'ret)))]
|
|
[(vectorof type) (with-syntax ([ret stx]
|
|
[trans-type (recur (syntax type))])
|
|
(syntax/loc stx (vectorof-contract trans-type #'ret)))]
|
|
[(boxof type) (with-syntax ([ret stx]
|
|
[trans-type (recur (syntax type))])
|
|
(syntax/loc stx (boxof-contract trans-type #'ret)))]
|
|
[(quote n) (with-syntax ([ret stx])
|
|
(syntax/loc stx (build-flat-contract (lambda (x) (eq? x 'n)) 'n #'ret)))]
|
|
[(domain ... -> range) (translate-arrow-contract stx intermediate-translate-contract)]
|
|
[else-stx (beginner-translate-contract (syntax else-stx) intermediate-translate-contract)])]))
|
|
|
|
;; stx definitions for advanced language contracts (advanced-contracts.scm)
|
|
(define advanced-translate-contract
|
|
(case-lambda
|
|
[(stx) (advanced-translate-contract stx advanced-translate-contract)]
|
|
[(stx recur)
|
|
(syntax-case* stx (-> void) contract-id=?
|
|
[void (with-syntax ([ret stx])
|
|
(syntax/loc stx (void-contract #'ret)))]
|
|
[(domain ... -> range) (translate-arrow-contract stx advanced-translate-contract)]
|
|
[else-stx (intermediate-translate-contract (syntax else-stx))])]))
|
|
|
|
;; helper functions for these
|
|
|
|
;;get-predicate-from-struct : stx -> stx
|
|
;;returns the predicate for the given stx, which needs to be an object defined via define-struct/define-data
|
|
(define (get-predicate-from-struct stx)
|
|
(caddr (syntax-local-value stx)))
|
|
|
|
;;get-cnt-from-dd : stx -> stx
|
|
;;returns the syntax contract that corresponds to the current define-data object
|
|
(define (get-cnt-from-dd stx)
|
|
(if (define-data? stx)
|
|
(caddr (syntax-local-value stx))))
|
|
|
|
;;get-name-from-struct : stx -> stx
|
|
;;returns the name for the given stx, which needs to be an object defined via define-struct/define-data
|
|
(define (get-name-from-struct stx)
|
|
(car (syntax-local-value stx)))
|
|
|
|
;;get-accessors-from-struct : stx -> list of stx
|
|
;;returns the name for the given stx, which needs to be an object defined via define-struct/define-data
|
|
(define (get-accessors-from-struct stx)
|
|
(cadddr (syntax-local-value stx)))
|
|
|
|
;;define-struct? : stx -> boolean
|
|
; was this thing defined in a define-struct?
|
|
(define (define-struct? stx)
|
|
(and (identifier? stx) (pair? (syntax-local-value stx (lambda () #f)))))
|
|
|
|
;;define-data? : stx -> boolean
|
|
; was this thing defined in a define-data?
|
|
(define (define-data? stx)
|
|
(and (identifier? stx)
|
|
(let ([data (syntax-local-value stx (lambda () #f))])
|
|
(and data (pair? data) (eq? (cadr data) 'define-data)))))
|
|
|
|
)
|