immutable-struct-constructor.rkt (4283B)
1 #lang typed/racket 2 3 (require typed/racket/unsafe 4 (for-syntax racket/struct-info 5 racket/list 6 racket/function) 7 (for-template phc-toolkit/untyped/meta-struct) 8 phc-toolkit) 9 (unsafe-require/typed racket/base 10 [struct-constructor-procedure? (→ Any Boolean)]) 11 12 (provide immutable-struct-constructor?) 13 14 (: immutable-struct-constructor? (→ Any Variable-Reference Boolean)) 15 (define (immutable-struct-constructor? v vr) 16 (and (struct-constructor-procedure? v) 17 (let ([s-name (object-name v)]) 18 (and (symbol? s-name) 19 (or (immutable-struct?/symbol s-name v vr) 20 (let ([mk-s (regexp-match #px"^make-(.*)$" 21 (symbol->string s-name))]) 22 (and mk-s (pair? (cdr mk-s)) (cadr mk-s) 23 (let ([sym (string->symbol (cadr mk-s))]) 24 (immutable-struct?/symbol sym v vr))))))))) 25 26 (define-syntax (meta-struct-immutable stx) 27 (syntax-case stx () 28 [(_ ident) 29 (let () 30 (define slv (syntax-local-value #'ident (λ () #f))) 31 (if (and slv 32 (struct-info? slv) 33 (let ([esi (extract-struct-info slv)]) 34 (and (last (fourth esi)) 35 (not (ormap identity (fifth esi)))))) 36 #'#t 37 #'#f))])) 38 39 (define-syntax (meta-struct-type-descriptor stx) 40 (syntax-case stx () 41 [(_ ident) 42 (let () 43 (define slv (syntax-local-value #'ident (λ () #f))) 44 #`#,(and slv 45 (struct-info? slv) 46 (first (extract-struct-info slv))))])) 47 48 (define-syntax (meta-struct-constructor stx) 49 (syntax-case stx () 50 [(_ ident) 51 (let () 52 (define slv (syntax-local-value #'ident (λ () #f))) 53 #`#,(and slv 54 (struct-info? slv) 55 (second (extract-struct-info slv))))])) 56 57 (define (raco-test-exn? [e : exn:fail:contract]) 58 ;; See TR issue #439 at https://github.com/racket/typed-racket/issues/439 59 (regexp-match #px"Attempted to use a struct type reflectively in untyped code" 60 (exn-message e))) 61 62 (: immutable-struct?/symbol (→ Symbol Any Variable-Reference Boolean)) 63 (define (immutable-struct?/symbol sym ctor vr) 64 (define meta-result 65 (call-with-values 66 (λ () 67 (eval `(,#'list* (,#'meta-struct-immutable ,sym) 68 (,#'meta-struct-type-descriptor ,sym) 69 (,#'meta-struct-constructor ,sym)) 70 (variable-reference->namespace vr))) 71 (λ l l))) 72 (and (pair? meta-result) 73 (pair? (car meta-result)) 74 (pair? (cdar meta-result)) 75 (let ([meta-probably-immutable? (equal? (caar meta-result) #t)] 76 [meta-descriptor (cadar meta-result)] 77 [meta-constructor (cddar meta-result)]) 78 (and meta-probably-immutable? 79 meta-descriptor 80 (struct-type? meta-descriptor) 81 ;; double-check, meta-probably-immutable? could be true if we 82 ;; use a constructor named make-st, but st is actually bound to a 83 ;; different struct. 84 (let ([try-immutable-struct-type 85 : (U #t #f 'raco-test-exn) 86 (with-handlers ([exn:fail:contract? 87 (λ ([e : exn:fail:contract]) 88 (if (raco-test-exn? e) 89 'raco-test-exn 90 #f))]) 91 (if (struct-type-is-immutable? meta-descriptor) 92 #t 93 #f))]) 94 (cond 95 [(eq? try-immutable-struct-type #t) 96 ;; double-check that the heuristic worked, and that the 97 ;; guessed struct's constructor is indeed the original one: 98 (eq? meta-constructor ctor)] 99 [(eq? try-immutable-struct-type 'raco-test-exn) 100 ;; the (eq? meta-constructor ctor) does not work properly 101 ;; with raco test either 102 #t] 103 [(eq? try-immutable-struct-type #f) 104 #f]))))))