contracts-to-types.rkt (4969B)
1 #lang type-expander 2 3 (provide :contract→type 4 (rename-out [c→t contract→type] 5 [c→t contract->type] 6 [:contract→type :contract->type])) 7 (require (prefix-in c: (combine-in racket/base racket/contract/base)) 8 (for-syntax racket/base 9 syntax/parse 10 syntax/parse/experimental/template 11 type-expander/expander)) 12 13 (begin-for-syntax 14 (define-syntax-class arrow 15 (pattern {~or {~literal ->} {~literal →} {~literal c:->}})) 16 (define-syntax-class arrow* 17 (pattern {~or {~literal ->*} {~literal c:->*}}))) 18 19 (define-type-expander c→t 20 (syntax-parser 21 [(_ ({~literal c:or/c} alt ...)) #'(U (c→t alt) ...)] 22 [(_ ({~literal c:and/c} alt ...)) #'(∩ (c→t alt) ...)] 23 [(_ ({~literal c:listof} c)) #'(Listof (c→t c))] 24 [(_ ({~literal c:list/c} c ...)) #'(List (c→t c) ...)] 25 [(_ ({~literal c:*list/c} prefix suffix ...)) 26 #'(Rec R (U (Pairof (c→t prefix) R) 27 (List (c→t suffix) ...)))] 28 [(_ ({~literal c:vectorof} c)) #'(Vectorof (c→t c))] 29 [(_ ({~literal c:vector/c} c ...)) #'(Vector (c→t c) ...)] 30 [(_ ({~literal c:cons/c} a d)) #'(Pairof (c→t a) (c→t d))] 31 [(_ {~literal c:number?}) #'Number] 32 [(_ {~literal c:integer?}) #'Integer] 33 [(_ {~literal c:string?}) #'String] 34 [(_ {~literal c:symbol?}) #'Symbol] 35 [(_ {~literal c:char?}) #'Char] 36 [(_ {~literal c:boolean?}) #'Boolean] 37 [(_ {~literal c:bytes?}) #'Bytes] 38 [(_ {~literal c:void?}) #'Void] 39 [(_ {~literal c:null?}) #'Null] 40 [(_ {~literal c:empty?}) #'Null] 41 [(_ {~literal c:list?}) #'(Listof Any)] 42 [(_ {~literal c:exact-nonnegative-integer?}) #'Exact-Nonnegative-Integer] 43 [(_ {~literal c:exact-positive-integer?}) #'Exact-Positive-Integer] 44 [(_ ({~literal c:syntax/c} τ)) #'(Syntaxof (c→t τ))] 45 [(_ ({~literal c:parameter/c} in)) #'(Parameterof (c→t in))] 46 [(_ ({~literal c:parameter/c} in out)) #'(Parameterof (c→t in) (c→t out))] 47 [(_ ({~literal c:promise/c} τ)) #'(Promise (c→t τ))] 48 [(_ ({~literal c:suggest/c} τ)) #'(c→t τ)] 49 [(_ ({~literal c:flat-rec-contract} R alt ...)) 50 #`(Rec R (U (c→t alt) ...))] 51 [(_ (a:arrow {~seq {~optional kw:keyword} 52 {~and arg {~not {~literal ...}}}} 53 ... 54 rest {~and {~literal ...} ooo} 55 result)) 56 #:with rest-kw (datum->syntax #'here '#:rest #'ooo) 57 #:with a* (datum->syntax #'here '->* #'a) 58 (template (a* ((?@ (?? kw) (c→t arg)) ...) 59 rest-kw (c→t rest) 60 (c→t result)))] 61 [(_ (a:arrow {~seq {~optional kw:keyword} 62 {~and arg {~not {~literal ...}}}} 63 ... 64 result)) 65 (template (a (?@ (?? kw) (c→t arg)) ... (c→t result)))] 66 [(_ (a*:arrow* ({~seq {~optional mandatory-kw:keyword} 67 mandatory-arg} 68 ...) 69 {~optional 70 {~and opt 71 ({~seq {~optional optional-kw:keyword} 72 optional-arg} 73 ...)}} 74 {~optional {~seq #:rest ({~literal c:listof} rest)}} 75 result)) 76 (quasitemplate (a* ((?@ (?? mandatory-kw) (c→t mandatory-arg)) ...) 77 #,@(if (attribute opt) 78 (template 79 {((?@ (?? optional-kw) (c→t optional-arg)) 80 ...)}) 81 #'{}) 82 (?? (?@ #:rest (c→t rest))) 83 (c→t result)))] 84 [(_ {~literal c:any}) #'AnyValues] 85 [(_ ({~literal c:values} v ...)) #'(Values (c→t v) ...)] 86 [(_ {~and τ ({~literal quote} _)}) #'τ] 87 [(_ {~and τ {~or :number :str :char :boolean}}) #''τ] 88 [(_ {~and τ}) #:when (bytes? (syntax-e #'τ)) #''τ] 89 [(_ {~and τ}) #:when (regexp? (syntax-e #'τ)) #''τ] 90 [(_ {~and τ}) #:when (byte-regexp? (syntax-e #'τ)) #''τ] 91 [(_ {~and τ ({~literal quasiquote} _)}) #'τ] 92 [(_ ({~literal unquote} τ)) #'τ] 93 [(_ v:id) 94 ;; TODO: this is a terrible implementation. type-expander should provide 95 ;; a way to attach information to an identifier, so that we can know that 96 ;; v is a variable bound by flat-rec-contract. 97 #'v] 98 [(_ c) (raise-syntax-error 99 'contract→type 100 (string-append 101 "I cannot convert this contract to a type automatically." 102 " Please fill in an issue at" 103 " https://github.com/jsmaniac/type-expander/issues if the" 104 " translation can easily be done automatically, or do the" 105 " translation manually otherwise. ") 106 #'c)])) 107 108 (define-syntax (:contract→type stx) 109 (syntax-case stx () 110 [(_ c) #`(writeln '#,(expand-type #`(c→t c)))]))