105 lines
4.2 KiB
Racket
105 lines
4.2 KiB
Racket
#lang typed/racket
|
|
|
|
(require typed/racket/unsafe
|
|
(for-syntax racket/struct-info
|
|
racket/list
|
|
racket/function)
|
|
(for-template phc-toolkit/untyped/meta-struct)
|
|
phc-toolkit)
|
|
(unsafe-require/typed racket/base
|
|
[struct-constructor-procedure? (→ Any Boolean)])
|
|
|
|
(provide immutable-struct-constructor?)
|
|
|
|
(: immutable-struct-constructor? (→ Any Variable-Reference Boolean))
|
|
(define (immutable-struct-constructor? v vr)
|
|
(and (struct-constructor-procedure? v)
|
|
(let ([s-name (object-name v)])
|
|
(and (symbol? s-name)
|
|
(or (immutable-struct?/symbol s-name v vr)
|
|
(let ([mk-s (regexp-match #px"^make-(.*)$"
|
|
(symbol->string s-name))])
|
|
(and mk-s (pair? (cdr mk-s)) (cadr mk-s)
|
|
(let ([sym (string->symbol (cadr mk-s))])
|
|
(immutable-struct?/symbol sym v vr)))))))))
|
|
|
|
(define-syntax (meta-struct-immutable stx)
|
|
(syntax-case stx ()
|
|
[(_ ident)
|
|
(let ()
|
|
(define slv (syntax-local-value #'ident (λ () #f)))
|
|
(if (and slv
|
|
(struct-info? slv)
|
|
(let ([esi (extract-struct-info slv)])
|
|
(and (last (fourth esi))
|
|
(not (ormap identity (fifth esi))))))
|
|
#'#t
|
|
#'#f))]))
|
|
|
|
(define-syntax (meta-struct-type-descriptor stx)
|
|
(syntax-case stx ()
|
|
[(_ ident)
|
|
(let ()
|
|
(define slv (syntax-local-value #'ident (λ () #f)))
|
|
#`#,(and slv
|
|
(struct-info? slv)
|
|
(first (extract-struct-info slv))))]))
|
|
|
|
(define-syntax (meta-struct-constructor stx)
|
|
(syntax-case stx ()
|
|
[(_ ident)
|
|
(let ()
|
|
(define slv (syntax-local-value #'ident (λ () #f)))
|
|
#`#,(and slv
|
|
(struct-info? slv)
|
|
(second (extract-struct-info slv))))]))
|
|
|
|
(define (raco-test-exn? [e : exn:fail:contract])
|
|
;; See TR issue #439 at https://github.com/racket/typed-racket/issues/439
|
|
(regexp-match #px"Attempted to use a struct type reflectively in untyped code"
|
|
(exn-message e)))
|
|
|
|
(: immutable-struct?/symbol (→ Symbol Any Variable-Reference Boolean))
|
|
(define (immutable-struct?/symbol sym ctor vr)
|
|
(define meta-result
|
|
(call-with-values
|
|
(λ ()
|
|
(eval `(,#'list* (,#'meta-struct-immutable ,sym)
|
|
(,#'meta-struct-type-descriptor ,sym)
|
|
(,#'meta-struct-constructor ,sym))
|
|
(variable-reference->namespace vr)))
|
|
(λ l l)))
|
|
(and (pair? meta-result)
|
|
(pair? (car meta-result))
|
|
(pair? (cdar meta-result))
|
|
(let ([meta-probably-immutable? (equal? (caar meta-result) #t)]
|
|
[meta-descriptor (cadar meta-result)]
|
|
[meta-constructor (cddar meta-result)])
|
|
(and meta-probably-immutable?
|
|
meta-descriptor
|
|
(struct-type? meta-descriptor)
|
|
;; double-check, meta-probably-immutable? could be true if we
|
|
;; use a constructor named make-st, but st is actually bound to a
|
|
;; different struct.
|
|
(let ([try-immutable-struct-type
|
|
: (U #t #f 'raco-test-exn)
|
|
(with-handlers ([exn:fail:contract?
|
|
(λ ([e : exn:fail:contract])
|
|
(if (raco-test-exn? e)
|
|
'raco-test-exn
|
|
#f))])
|
|
(if (struct-type-is-immutable? meta-descriptor)
|
|
#t
|
|
#f))])
|
|
(cond
|
|
[(eq? try-immutable-struct-type #t)
|
|
;; double-check that the heuristic worked, and that the
|
|
;; guessed struct's constructor is indeed the original one:
|
|
(eq? meta-constructor ctor)]
|
|
[(eq? try-immutable-struct-type 'raco-test-exn)
|
|
;; the (eq? meta-constructor ctor) does not work properly
|
|
;; with raco test either
|
|
#t]
|
|
[(eq? try-immutable-struct-type #f)
|
|
#f]))))))
|