meta-struct.rkt (4632B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 (require (for-syntax syntax/parse/experimental/template 5 syntax/parse 6 racket/syntax)) 7 8 (begin-for-syntax 9 (provide meta-struct? 10 (struct-out meta-struct-info) 11 get-meta-struct-info 12 ;; More provided by `shorthand` in the code below 13 meta-struct-subtype? 14 struct-type-id-is-immutable?)) 15 (provide struct-predicate 16 struct-constructor 17 struct-accessor 18 struct-type-is-immutable? 19 struct-instance-is-immutable?) 20 21 (module info racket/base 22 (require racket/struct-info) 23 24 (provide meta-struct? 25 (struct-out meta-struct-info) 26 get-meta-struct-info) 27 28 (define (meta-struct? s) 29 (and (identifier? s) 30 (let ([v (syntax-local-value s (λ _ #f))]) 31 (and v (struct-info? v))))) 32 33 (struct meta-struct-info 34 (type-descriptor 35 constructor 36 predicate 37 accessors 38 mutators 39 super-type) 40 #:transparent) 41 42 (define (get-meta-struct-info s 43 #:srcloc [srcloc #f] 44 #:fallback [fallback #f]) 45 (if (meta-struct? s) 46 (apply meta-struct-info 47 (extract-struct-info (syntax-local-value s))) 48 (if fallback 49 (fallback) 50 (raise-syntax-error 'get-struct-info 51 "not a structure definition" 52 (or srcloc s) 53 s))))) 54 55 (require 'info 56 (for-syntax 'info)) 57 58 (define-syntax (shorthand stx) 59 (syntax-case stx () 60 [(_ base) 61 (with-syntax ([name (format-id #'base "meta-struct-~a" #'base)] 62 [accessor (format-id #'base "meta-struct-info-~a" #'base)] 63 [tmpl (format-id #'base "!struct-~a" #'base)]) 64 #'(begin-for-syntax 65 (provide name tmpl) 66 (define-template-metafunction (tmpl stx) 67 (syntax-parse stx 68 [(_ s 69 (~optional (~seq #:srcloc srcloc)) 70 (~optional (~seq #:fallback fallback))) 71 (accessor 72 (get-meta-struct-info #'s #:srcloc (attribute srcloc)))])) 73 (define (name s #:srcloc [srcloc #f] #:fallback [fallback #f]) 74 (define err (gensym)) 75 (define val 76 (get-meta-struct-info s 77 #:srcloc srcloc 78 #:fallback (and fallback (λ () err)))) 79 (if (and (eq? val err) fallback) 80 (fallback) 81 (accessor val)))))])) 82 83 (shorthand type-descriptor) 84 (shorthand constructor) 85 (shorthand predicate) 86 (shorthand accessors) 87 (shorthand mutators) 88 (shorthand super-type) 89 90 (define-syntax (struct-predicate stx) 91 (syntax-case stx () 92 [(_ s) (meta-struct-info-predicate (get-meta-struct-info #'s))])) 93 (define-syntax (struct-constructor stx) 94 (syntax-case stx () 95 [(_ s) (meta-struct-info-constructor (get-meta-struct-info #'s))])) 96 (define-syntax (struct-accessor stx) 97 (syntax-case stx () 98 [(_ s field) 99 (identifier? #'field) 100 (begin 101 (record-disappeared-uses (list #'s #'field)) 102 (format-id #'s "~a-~a" #'s #'field))] 103 [(_ s i) 104 (exact-positive-integer? (syntax-e #'i)) 105 (list-ref (meta-struct-info-accessors (get-meta-struct-info #'s)) 106 (syntax-e #'i))])) 107 108 (define-for-syntax (meta-struct-subtype? sub super) 109 (or (equal? (meta-struct-type-descriptor sub) 110 (meta-struct-type-descriptor super)) 111 (let ((up (meta-struct-super-type sub))) 112 (and (meta-struct? up) 113 (meta-struct-subtype? up super))))) 114 115 (define-for-syntax (struct-type-id-is-immutable? id) 116 (andmap not (meta-struct-mutators id))) 117 118 (define (struct-type-is-immutable? [st : Struct-TypeTop]) : Boolean 119 (let-values ([(_1 nfields _3 _4 _5 immutable-idx super not-most-specific?) 120 (struct-type-info st)]) 121 (and (not not-most-specific?) 122 (equal? (sort immutable-idx <) 123 (range nfields)) 124 (if super (struct-type-is-immutable? super) #t)))) 125 126 (define (struct-instance-is-immutable? v) 127 128 (let-values ([(st not-most-specific?) (struct-info v)]) 129 (and (not not-most-specific?) 130 st 131 (struct-type-is-immutable? st)))))