main.rkt (10921B)
1 #lang racket/base 2 3 ;; The provide form is at the bottom of the file, as it needs to use some 4 ;; provide transformers defined within this file. 5 6 (require "private/ids.rkt" 7 racket/contract ;; TODO: remove if not needed. 8 (for-syntax racket/base 9 racket/list 10 racket/require-transform 11 racket/provide-transform 12 syntax/parse 13 "private/utils.rkt" 14 racket/contract) 15 (for-meta 2 racket/base)) 16 17 ;; Definition of polysemic identifiers and parts of these 18 ;; _____________________________________________________________________________ 19 20 (define-syntax (define-poly stx) 21 (syntax-case stx () 22 ;; Definition of a new polysemic identifier 23 [(_ id) 24 (with-syntax ([safeguard (gen-id #'id '| safeguard |)]) 25 ;; TODO: this won't handle local shadowings very well. 26 (if (and (identifier-binding #'id) (identifier-binding #'safeguard)) 27 #'(begin) 28 #`(local-require 29 (only-in polysemy/private/ids 30 #,@(if (identifier-binding #'id) 31 #'{} 32 #'{[the-polysemic-id id]}) 33 #,@(if (identifier-binding #'safeguard) 34 #'{} 35 #'{[the-safeguard-id safeguard]})))))] 36 ;; Definition of a part of a (possibly new) polysemic identifier 37 [(_ id meaning value) 38 (with-syntax ([safeguard (gen-id #'id '| safeguard |)] 39 [generated-id (gen-id #'id (syntax-e #'meaning))]) 40 (with-syntax ([define-meaning #'(define-syntax generated-id value)]) 41 (register-meanings (syntax->datum #'(meaning))) 42 ;; TODO: this won't handle local shadowings very well. 43 (if (and (identifier-binding #'id) (identifier-binding #'safeguard)) 44 #'define-meaning 45 #'(begin 46 (define-poly id) 47 define-meaning))))])) 48 49 ;; Syntax-parse pattern expander which extracts the given meaning from the 50 ;; matched id 51 (begin-for-syntax 52 (define-syntax-class (poly-stxclass meaning) 53 #:attributes (value) 54 (pattern pvar:id 55 #:attr value (syntax-local-value (gen-id #'pvar meaning) 56 (λ () #f)) 57 #:when (attribute value))) 58 (define-syntax ~poly 59 (pattern-expander 60 (λ (stx) 61 (syntax-case stx () 62 [(_ pvar meaning) 63 ;; Do we need to (register-meanings #'(meaning)) here? I think not. 64 #'{~and {~var pvar (poly-stxclass 'meaning)}}]))))) 65 66 (define-syntax-rule (define-poly-literal initial-id meaning syntax-class) 67 (begin 68 (define-poly initial-id meaning 69 (λ (stx) (raise-syntax-error 'initial-id "reserved identifier" stx))) 70 (begin-for-syntax 71 (define-syntax-class syntax-class 72 #:attributes () 73 ;; TODO: the description is not present in error messages. Why ? 74 ;#:description 75 ;(format "the ~a meaning (originally bound to the ~a identifier)" 76 ; 'meaning 77 ; 'initial-id) 78 (pattern {~poly _ meaning}))))) 79 80 ;; TODO: multimethods 81 (define-syntax (define-poly-case stx) 82 (syntax-case stx () 83 [(_ (name [arg₀ pred?] argᵢ ...) . body) 84 (let ([meaning (string->symbol 85 (format "~a" `(poly-case ,(syntax-e #'pred?))))]) 86 (with-syntax 87 ([generated-name (gen-id #'name meaning)] 88 [generated-normal-macro (gen-id #'name 'normal-macro)] 89 [generated-identifier-macro (gen-id #'name 'identifier-macro)]) 90 (register-meanings `(,meaning)) 91 #`(begin 92 (define-poly name) 93 ;; TODO: provide keywords to selectively disable the 94 ;; identifier-macro or normal-macro behaviours. Also check that 95 ;; if identifier-binding does not return #f, it returns a binding 96 ;; for the-case-dispatch, and not for something else. 97 #,@(if (identifier-binding #'generated-normal-macro) 98 #'{} 99 #'{(local-require 100 (only-in polysemy/private/ids 101 [the-case-dispatch generated-normal-macro]))}) 102 #,@(if (identifier-binding #'generated-identifier-macro) 103 #'{} 104 #'{(local-require 105 (only-in polysemy/private/ids 106 [the-case-dispatch 107 generated-identifier-macro]))}) 108 (define/contract (tmp-f arg₀ argᵢ ...) 109 (-> pred? (or/c 'argᵢ 'TODO any/c) ... any) 110 . body) 111 (define-syntax generated-name (a-case #'tmp-f #'pred?)))))])) 112 113 ;; Require/provide transformers 114 ;; _____________________________________________________________________________ 115 116 117 (begin-for-syntax 118 (define-syntax-class poly-meaning-expander-sc 119 #:attributes ([expanded 1]) 120 (pattern {~poly x poly-reqprov-id-expander} 121 #:with (tmp:poly-meaning-expander-sc ...) 122 ((attribute x.value) #'x) 123 #:with (expanded ...) #'(tmp.expanded ... ...)) 124 (pattern x:id #:with (expanded ...) #'(x)) 125 (pattern {~and whole ({~poly x poly-meaning-expander} . _)} 126 #:with (tmp:poly-meaning-expander-sc ...) 127 ((attribute x.value) #'whole) 128 #:with (expanded ...) #'(tmp.expanded ... ...)))) 129 (define-poly case-function poly-meaning-expander 130 (λ (stx) 131 (syntax-case stx () 132 ;; TODO: make the normal-macro and identifier-macro switchable. 133 [(_ pred?) #`(normal-macro 134 identifier-macro 135 #,(string->symbol 136 (format "~a" `(poly-case ,(syntax-e #'pred?)))))]))) 137 138 ;; Require transformers 139 ;; _____________________________________________________________________________ 140 141 ;; Common implementation for the poly-rename-in and poly-only-in rename 142 ;; transformers. 143 (define-for-syntax (poly-require-transformer req stx) 144 (syntax-parse stx 145 [(_ mod 146 [{~or {~and :id old-id new-id} (old-id:id new-id:id)} 147 meaning:poly-meaning-expander-sc 148 ...] 149 ...) 150 #:with ((old-generated-id ...) ...) 151 (map (λ (id meanings) 152 (map (λ (meaning) (gen-id id (syntax-e meaning))) 153 (remove-duplicates (syntax->list meanings) free-identifier=?))) 154 (syntax->list #'(old-id ...)) 155 (syntax->list #'((meaning.expanded ... ...) ...))) 156 #:with ((new-generated-id ...) ...) 157 (map (λ (id meanings) 158 (map (λ (meaning) (gen-id id (syntax-e meaning))) 159 (remove-duplicates (syntax->list meanings) free-identifier=?))) 160 (syntax->list #'(new-id ...)) 161 (syntax->list #'((meaning.expanded ... ...) ...))) 162 #:with (new-id-no-duplicates ...) 163 (remove-duplicates (syntax->list #'(new-id ...)) 164 free-identifier=?) 165 #:with (new-safeguard-no-duplicates ...) 166 (map (λ (one-id) (gen-id one-id '| safeguard |)) 167 (syntax->list #'(new-id-no-duplicates ...))) 168 (register-meanings (syntax->datum #'(meaning.expanded ... ... ...))) 169 (expand-import 170 #`(combine-in 171 ;; We always require the same ids, so that multiple requires 172 ;; are a no-op, instead of causing conflicts. 173 (only-in polysemy/private/ids 174 [the-polysemic-id new-id-no-duplicates] ... 175 [the-safeguard-id new-safeguard-no-duplicates] ...) 176 (#,req mod [old-generated-id new-generated-id] ... ...)))])) 177 178 ;; Require transformer which allows renaming parts of polysemic identifiers. 179 (define-syntax poly-rename-in 180 (make-require-transformer 181 (λ (stx) (poly-require-transformer #'rename-in stx)))) 182 183 ;; Require transformer which allows selecting and renaming parts of polysemic 184 ;; identifiers. 185 (define-syntax poly-only-in 186 (make-require-transformer 187 (λ (stx) (poly-require-transformer #'only-in stx)))) 188 189 ;; Provide transformer 190 ;; _____________________________________________________________________________ 191 192 (define-syntax poly-out 193 (make-provide-pre-transformer 194 (λ (provide-spec modes) 195 (syntax-parse provide-spec 196 [(_ [{~or {~and :id old-id new-id} (old-id:id new-id:id)} 197 meaning:poly-meaning-expander-sc ...] 198 ...) 199 (with-syntax ([((old-generated-id ...) ...) 200 (map (λ (one-id meanings) 201 (map (λ (one-meaning) 202 (gen-id one-id (syntax-e one-meaning))) 203 (remove-duplicates (syntax->list meanings) 204 free-identifier=?))) 205 (syntax->list #'(old-id ...)) 206 (syntax->list #'((meaning.expanded ... ...) ...)))] 207 [((new-generated-id ...) ...) 208 (map (λ (one-id meanings) 209 (map (λ (one-meaning) 210 (gen-id one-id (syntax-e one-meaning))) 211 (remove-duplicates (syntax->list meanings) 212 free-identifier=?))) 213 (syntax->list #'(new-id ...)) 214 (syntax->list #'((meaning.expanded ... ...) ...)))] 215 [(old-safeguard ...) 216 (map (λ (one-id) (gen-id one-id '| safeguard |)) 217 (syntax->list #'(old-id ...)))] 218 [(new-safeguard ...) 219 (map (λ (one-id) (gen-id one-id '| safeguard |)) 220 (syntax->list #'(new-id ...)))]) 221 (register-meanings (syntax->datum #'(meaning.expanded ... ... ...))) 222 (pre-expand-export #'(rename-out [old-safeguard new-safeguard] ... 223 [old-id new-id] ... 224 [old-generated-id new-generated-id] 225 ... ...) 226 modes))])))) 227 228 (provide 229 ;; A require transformer 230 poly-rename-in 231 ;; Another require transformer 232 poly-only-in 233 ;; Provide transformer 234 poly-out 235 ;; Definition of a polysemic id, and of a part of a polysemic id 236 define-poly 237 ;; Syntax-parse pattern expander which extracts the given meaning from the id 238 (for-syntax ~poly) 239 ;; Defines a literal which can be renamed, without conflicting with other 240 ;; poly literals, or identifiers with other meanings. 241 define-poly-literal 242 ;; Defines a static overload for a polysemic method 243 define-poly-case 244 ;; Syntactic token used to build case-function meanings 245 ;; TODO: We probably should make it a case-function-expander instead of a token 246 (poly-out [case-function poly-meaning-expander]))