ids.rkt (9350B)
1 #lang racket/base 2 3 (require racket/match 4 racket/contract 5 (for-syntax racket/base 6 racket/contract 7 racket/set 8 syntax/id-table 9 syntax/id-set 10 "utils.rkt")) 11 12 (provide 13 ;; The only polysemic id (all others are renamings of this one) 14 the-polysemic-id 15 ;; The only safeguard id (all others are renamings of this one) 16 the-safeguard-id 17 ;; The only case-dispatch macro (all others are renamings of this one) 18 the-case-dispatch 19 ;; Records all known meanings 20 (for-syntax all-meanings 21 register-meanings)) 22 (begin-for-syntax 23 (provide 24 ;; Represents a single overload of a function 25 (struct-out a-case))) 26 27 ;; We can have a safeguard identifier to detect uses of rename-in, rename-out 28 ;; and only-in, instead of their poly- counterparts. The safeguard 29 ;; identifier does not do anything, but should always be available. If it is not 30 ;; available it means that some unprotected renaming occurred, and an error is 31 ;; thrown. 32 (define-syntax the-safeguard-id 33 (λ (stx) 34 (raise-syntax-error 'safeguard "Invalid use of internal identifier" stx))) 35 36 ;; Shorthand for syntax-local-value 37 (define-for-syntax (maybe-slv id) (syntax-local-value id (λ () #f))) 38 39 ;; Creates a wrapper for a prop:…, by extracting the the given `meaning` 40 ;; for the identifier. 41 (define-for-syntax ((make-wrapper meaning fallback-id fallback-app) stx) 42 (syntax-case stx () 43 [(self . rest) 44 (let ([slv (maybe-slv (gen-id/check #'self meaning))]) 45 (if slv 46 (slv stx) 47 (fallback-app stx #'self #'rest)))] 48 [self 49 (identifier? #'self) 50 (let ([slv (maybe-slv (gen-id/check #'self meaning))]) 51 (if slv 52 (slv stx) 53 (fallback-id stx)))] 54 [_ 55 (raise-syntax-error 'polysemic-identifier 56 "illegal use of polysemic identifier" 57 stx)])) 58 59 ;; Wrapper for prop:procedure on a transformer id. 60 ;; Dispatches to 61 (define-for-syntax (macro-wrapper _self stx) 62 (syntax-case stx (set!) 63 [(set! v . _) 64 (let ([slv (maybe-slv (gen-id/check #'v 'set!-macro))]) 65 (if slv 66 (slv stx) 67 (raise-syntax-error 68 'set! 69 (format "Assignment with set! is not allowed for ~a" 70 (syntax->datum #'v)) 71 stx)))] 72 [(self . rest) 73 (let ([slv (maybe-slv (gen-id/check #'self 'normal-macro))]) 74 (if slv 75 (slv stx) 76 (datum->syntax 77 stx 78 `((,(datum->syntax #'self '#%top #'self #'self) . ,#'self) 79 . ,#'rest) 80 stx 81 stx)))] 82 [x 83 (identifier? #'x) 84 (begin 85 (let ([slv (maybe-slv (gen-id/check #'x 'identifier-macro))]) 86 (if slv 87 (slv stx) 88 (datum->syntax stx `(#%top . ,#'x) stx stx))))] 89 [_ 90 (raise-syntax-error 'polysemic-identifier 91 "illegal use of polysemic identifier" 92 stx)])) 93 94 ;; An instance of this struct are bound (as transformer values) to the (only) 95 ;; polysemic id. 96 (begin-for-syntax 97 (struct polysemic () 98 #:property prop:match-expander 99 (make-wrapper 'match-expander 100 (λ (id) #`(var #,id)) 101 (λ (stx id args) (raise-syntax-error 102 'match 103 "syntax error in pattern" 104 stx))) 105 #:property prop:procedure macro-wrapper)) 106 107 ;; The only polysemic id (all others are renamings of this one) 108 (define-syntax the-polysemic-id (polysemic)) 109 110 ;; Record all known meanigns, so that the-case-dispatch-impl can perform some 111 ;; sanity checks. 112 (define-for-syntax ignore-err-rx 113 #px"not currently transforming an expression within a module declaration") 114 (begin-for-syntax 115 (define/contract all-meanings (set/c symbol? #:kind 'mutable) (mutable-set)) 116 (define/contract (register-meanings-end syms) 117 (-> (listof symbol?) void?) 118 (for ([meaning (in-list syms)]) 119 (set-add! all-meanings meaning))) 120 121 (define/contract (register-meanings syms) 122 (-> (listof symbol?) void?) 123 (for ([meaning (in-list syms)]) 124 (set-add! all-meanings meaning)) 125 (with-handlers ([(λ (e) 126 (and exn:fail:contract? 127 (not (eq? (syntax-local-context) 'module)) 128 (regexp-match ignore-err-rx (exn-message e)))) 129 (λ (e) (void))]) 130 ;; I'm not sure if this is really needed. 131 (syntax-local-lift-module-end-declaration 132 #`(begin-for-syntax 133 (register-meanings-end '#,syms)))))) 134 135 (begin-for-syntax 136 ;; Represents a single overload of a function (function-id + predicate-id) 137 (struct a-case (f-id pred-id) #:transparent)) 138 139 ;; (FreeIdTable Id (Listof Id)) 140 (define-for-syntax contracts-supertypes #f) 141 ;; (FreeIdTable Id (Listof Id)) 142 (define-for-syntax contracts-expand #f) 143 (define-for-syntax (detect-overlap stx pred-ids) 144 ;; Lazily fill in the supertypes hash table, to avoid compile-time costs 145 ;; when the module is later required. 146 (unless contracts-supertypes 147 (set! contracts-supertypes 148 (make-free-id-table 149 `((,#'any/c . ()) 150 (,#'string? . (,#'any/c)) 151 (,#'exact-positive-integer? . (,#'exact-integer? ,#'positive?)) 152 (,#'exact-integer . (,#'integer? ,#'exact?)) 153 (,#'integer? . (,#'number?)) 154 (,#'exact? . (,#'number?)) ;; not quite right 155 (,#'number? . (,#'any/c)) 156 (,#'zero? . (,#'integer?)) 157 (,#'boolean? . (,#'any/c)) 158 (,#'list? . (,#'any/c)) 159 #;…)))) 160 ;; Lazily fill in the "expansion" hash table, to avoid compile-time costs 161 ;; when the module is later required. 162 (unless contracts-expand 163 (set! contracts-expand 164 (make-free-id-table 165 `((,#'exact-nonnegative-integer? . (,#'zero? 166 ,#'exact-positive-integer?)) 167 #;…)))) 168 ;; Build the set of covered contracts. When a contract is a union of two 169 ;; disjoint contracts, it is replaced by these 170 ;; (e.g. exact-nonnegative-integer? is replaced by zero? and 171 ;; exact-positive-integer?) 172 (define covered-ids (mutable-free-id-set)) 173 (for/list ([pred-id (in-list pred-ids)]) 174 (define expanded* 175 (free-id-table-ref contracts-expand 176 pred-id 177 (λ () (list pred-id)))) 178 (for ([expanded (in-list expanded*)]) 179 (when (free-id-set-member? covered-ids expanded) 180 (raise-syntax-error 'polysemy 181 "some available function cases overlap" 182 stx 183 #f 184 pred-ids)) 185 (free-id-set-add! covered-ids expanded))) 186 ;; Move up the inheritance DAG, and see if any of the ancestors 187 ;; is covered. Since we start with the parents of the user-supplied contract, 188 ;; there will be no self-detection. 189 (define already-recur (mutable-free-id-set)) 190 (define (recur pred-id) 191 (unless (free-id-set-member? already-recur pred-id) 192 (free-id-set-add! already-recur pred-id) 193 (when (free-id-set-member? covered-ids pred-id) 194 (raise-syntax-error 'polysemy 195 "some available function cases overlap" 196 stx 197 #f 198 pred-ids)) 199 (for-each recur (free-id-table-ref contracts-supertypes pred-id)))) 200 (for ([pred-id (in-list pred-ids)]) 201 (apply recur (free-id-table-ref contracts-supertypes 202 pred-id)))) 203 204 (define-for-syntax (the-case-dispatch-impl stx) 205 (syntax-case stx () 206 [(id . args) 207 (identifier? #'id) 208 #`(#%app #,(the-case-dispatch-impl #'id) . args)] 209 [id 210 (identifier? #'id) 211 (with-syntax 212 ([((f-id pred-id) ...) 213 (for*/list ([meaning (in-set all-meanings)] 214 [generated-name (in-value (gen-id #'id meaning))] 215 [slv (in-value 216 (syntax-local-value generated-name (λ () #f)))] 217 #:when (and slv (a-case? slv))) 218 (list (a-case-f-id slv) 219 (a-case-pred-id slv)))]) 220 ;; Detect if there is overlap among the predicates, and raise an error 221 ;; in that case. 222 (detect-overlap #'id (syntax->list #'(pred-id ...))) 223 ;; TODO: for now, this only supports a single argument. 224 ;; we should generalize it to support case-λ, and dispatch on 225 ;; multiple arguments 226 ;; TODO: use syntax-local-lift-expression to cache 227 ;; the generated dispatch functions. Beware of all the failure 228 ;; modes: it is very easy to lift a variable in an expression 229 ;; context, and try to use it in another nested context outside of 230 ;; the lifted expression's scope. 231 #`(let () 232 (define/contract (id arg) 233 (-> (or/c pred-id ...) any) 234 (cond 235 [(pred-id arg) (f-id arg)] 236 ...)) 237 id))])) 238 239 ;; The only case-dispatch macro (all others are renamings of this one) 240 (define-syntax the-case-dispatch the-case-dispatch-impl)