ck.rkt (1428B)
1 #lang typed/racket/base 2 3 (require phc-toolkit 4 typed/rackunit 5 type-expander 6 racket/string 7 (for-syntax racket/base 8 phc-toolkit/untyped) 9 (lib "phc-adt/ctx.hl.rkt")) 10 11 (provide ck 12 ck-not 13 check-print-type) 14 15 (define-syntax (ck stx) 16 (syntax-case stx () 17 [(_ v t) 18 (quasisyntax/top-loc stx 19 (check-tc 20 (require (only-in (lib "phc-adt/ctx.hl.rkt") set-adt-context-macro)) 21 (set-adt-context-macro #,(datum->syntax #'t 'there)) 22 (ann v t)))])) 23 24 (define-syntax (ck-not stx) 25 (syntax-case stx () 26 [(_ v t) 27 (quasisyntax/top-loc stx 28 (check-not-tc 29 (require (only-in (lib "phc-adt/ctx.hl.rkt") set-adt-context-macro)) 30 (set-adt-context-macro #,(datum->syntax #'t 'there)) 31 (ann v t)))])) 32 33 (: clean-type-str (→ String String)) 34 (define (clean-type-str type-str) 35 (string-trim 36 (regexp-replace* #px"(?-s:[ \n]+)" 37 (regexp-replace #px"^- :" type-str "") 38 " "))) 39 40 (define-syntax/case (check-print-type e str) () 41 (eval-tc 42 (λ (f) 43 (quasisyntax/top-loc stx 44 (check-equal?: (clean-type-str (#,f)) str))) 45 (quasisyntax/top-loc stx 46 (begin (current-print (λ _ (void))) 47 (require (only-in (lib "phc-adt/ctx.hl.rkt") set-adt-context-macro)) 48 (set-adt-context-macro #,(datum->syntax #'t 'there)) 49 e))))