contract.rkt (7093B)
1 #lang racket/base 2 3 (provide kw-hash->) 4 5 (require racket/contract/base 6 racket/contract/combinator 7 racket/function 8 racket/list 9 "../keyword-lambda.rkt" 10 "../kw-hash.rkt" 11 (for-syntax racket/base 12 syntax/parse 13 )) 14 (module+ test 15 (require rackunit racket/contract/region)) 16 17 (define-syntax kw-hash-> 18 (lambda (stx) 19 (syntax-parse stx #:literals (any) 20 [(kw-hash-> [arg/c ...] #:kws kw-hash/c any) 21 #:declare arg/c (expr/c #'chaperone-contract? #:name "argument contract") 22 #:declare kw-hash/c (expr/c #'chaperone-contract? #:name "kw-hash contract") 23 (syntax/loc stx 24 (make-kw-hash->any (list arg/c.c ...) #false kw-hash/c.c))] 25 [(kw-hash-> [arg/c ...] #:rest rest/c #:kws kw-hash/c any) 26 #:declare arg/c (expr/c #'chaperone-contract? #:name "argument contract") 27 #:declare rest/c (expr/c #'chaperone-contract? #:name "rest contract") 28 #:declare kw-hash/c (expr/c #'chaperone-contract? #:name "kw-hash contract") 29 (syntax/loc stx 30 (make-kw-hash->any (list arg/c.c ...) rest/c.c kw-hash/c.c))] 31 ))) 32 33 ;; make-kw-hash->any : 34 ;; (Listof Chaperone-Contract) (Maybe Chaperone-Contract) Chaperone-Contract -> Chaperone-Contract 35 ;; The function that kw-hash-> expands into 36 (define (make-kw-hash->any arg-ctcs rest-ctc kw-hash-ctc) 37 (make-chaperone-contract 38 #:name `(kw-hash-> ,(map contract-name arg-ctcs) 39 ,@(if rest-ctc 40 `(#:rest ,(contract-name rest-ctc)) 41 `()) 42 #:kws ,(contract-name kw-hash-ctc) 43 any) 44 #:first-order procedure? 45 #:projection (make-kw-hash->any-proj 46 (map contract-projection arg-ctcs) 47 (and rest-ctc (contract-projection rest-ctc)) 48 (contract-projection kw-hash-ctc)))) 49 50 ;; Proj is [Blame -> [Any -> Any]] 51 52 ;; make-kw-hash->any-proj : (Listof Proj) (Maybe Proj) Proj -> Proj 53 ;; Makes projections for kw-hash-> contracts 54 (define ((make-kw-hash->any-proj arg-projs rest-proj kw-hash-proj) blame) 55 (define n (length arg-projs)) 56 ;; arg-wrappers : (Listof [Arg -> Arg]) 57 (define arg-wrappers 58 (get-arg-wrappers blame arg-projs)) 59 ;; rest-wrapper : (Option [(Listof Any) -> (Listof Any)]) 60 (define rest-wrapper 61 (and rest-proj (get-arg-wrapper blame rest-proj "the rest argument of"))) 62 ;; kws-wrapper : [Kws-Hash -> Kws-Hash] 63 (define kws-wrapper 64 (get-arg-wrapper blame kw-hash-proj "the keywords of")) 65 (lambda (f) 66 (check-procedure blame f) 67 (chaperone-procedure 68 f 69 (keyword-lambda (kws kw-args . args) 70 (with-continuation-mark 71 contract-continuation-mark-key blame 72 (let () 73 (check-length blame f (length args) 74 (if rest-wrapper 75 (arity-at-least n) 76 n)) 77 (define args* 78 (map app arg-wrappers (take args n))) 79 (define rest* 80 (and rest-wrapper (rest-wrapper (drop args n)))) 81 (define args+rest* 82 (if rest-wrapper 83 (append args* rest*) 84 args*)) 85 (define kw-hash* 86 (kws-wrapper (keyword-app-make-kw-hash kws kw-args))) 87 ;; kw-args* has to be in the same order as kw-args 88 (define kw-args* 89 (map-hash-ref kw-hash* kws)) 90 (if (null? kw-args*) 91 ;; if no keywords were passed in, don't include them 92 (apply values args+rest*) 93 (apply values kw-args* args+rest*)))))))) 94 95 ;; check-procedure : Blame Any -> Void 96 (define (check-procedure blame f) 97 (unless (procedure? f) 98 (raise-blame-error blame f '(expected: "procedure?" given: "~e") f))) 99 100 ;; check-length : Blame Any Natural Procedure-Arity -> Void 101 (define (check-length blame f actual-length expected-arity) 102 (unless (arity-includes? expected-arity actual-length) 103 (cond 104 [(exact-nonnegative-integer? expected-arity) 105 (raise-blame-error (blame-swap blame) f 106 '(expected: "~v arguments" given: "~v non-keyword arguments") 107 expected-arity actual-length)] 108 [(arity-at-least? expected-arity) 109 (raise-blame-error (blame-swap blame) f 110 '(expected: "at least ~v arguments" given: "~v non-keyword arguments") 111 (arity-at-least-value expected-arity) actual-length)] 112 [else 113 (raise-blame-error (blame-swap blame) f 114 '(expected: "arity ~v" given: "~v non-keyword arguments") 115 expected-arity actual-length)]))) 116 117 ;; app : [a -> b] a -> b 118 (define (app f a) 119 (f a)) 120 121 ;; map-hash-ref : (Hashof a b) (Listof a) -> (Listof b) 122 (define (map-hash-ref hash lst) 123 (for/list ([key (in-list lst)]) 124 (hash-ref hash key))) 125 126 ;; get-arg-wrapper : Blame Proj String -> [Any -> Any] 127 (define (get-arg-wrapper blame proj context) 128 (define arg-blame 129 (blame-add-context blame context #:swap? #t)) 130 (proj arg-blame)) 131 132 ;; get-arg-wrappers : Blame (Listof Proj) -> (Listof [Any -> Any]) 133 (define (get-arg-wrappers blame arg-projs) 134 (for/list ([proj (in-list arg-projs)] 135 [i (in-naturals)]) 136 (get-arg-wrapper blame proj (format "argument ~v of" i)))) 137 138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 140 (module+ test 141 (define c 142 (kw-hash-> [number? (listof symbol?)] #:kws (hash/c keyword? string?) any)) 143 (define c2 144 (kw-hash-> [number? (listof symbol?)] #:rest (listof 1) #:kws (hash/c keyword? string?) any)) 145 (check-pred chaperone-contract? c) 146 (check-pred chaperone-contract? c2) 147 (check-equal? (contract-name c) 148 '(kw-hash-> [number? (listof symbol?)] #:kws (hash/c keyword? string?) any)) 149 (check-equal? (contract-name c2) 150 '(kw-hash-> [number? (listof symbol?)] 151 #:rest (listof 1) #:kws (hash/c keyword? string?) 152 any)) 153 (define/contract (f x syms #:hello [hello "hello"]) 154 c 155 x) 156 (check-equal? (f 3 '(a b c)) 3) 157 (check-equal? (f 3 '(a b c) #:hello "wirled") 3) 158 (check-exn exn:fail:contract:blame? 159 (λ () (f 'three '(a b c)))) 160 (check-exn exn:fail:contract:blame? 161 (λ () (f 3 '(one two 5)))) 162 (check-exn exn:fail:contract:blame? 163 (λ () (f 3 '(a b c) #:hello 'not-a-string))) 164 (define/contract (f2 x syms #:hello [hello "hello"] . rst) 165 c2 166 x) 167 (check-equal? (f2 3 '(a b c)) 3) 168 (check-equal? (f2 3 '(a b c) #:hello "wirled") 3) 169 (check-equal? (f2 3 '(a b c) 1 1 1 1) 3) 170 (check-equal? (f2 3 '(a b c) 1 #:hello "wirled" 1 1 1) 3) 171 (check-exn exn:fail:contract:blame? 172 (λ () (f2 'three '(a b c)))) 173 (check-exn exn:fail:contract:blame? 174 (λ () (f2 3 '(one two 5)))) 175 (check-exn exn:fail:contract:blame? 176 (λ () (f2 3 '(a b c) #:hello 'not-a-string))) 177 (check-exn exn:fail:contract:blame? 178 (λ () (f2 3 '(a b c) 1 1 1 2))) 179 )