typed-syntax-convert2.rkt (12789B)
1 #lang typed/racket 2 3 (require typed-map 4 typed/racket/unsafe 5 "typed-prefab-declarations.rkt") 6 7 (provide ISyntaxOf 8 ISyntaxOf-E 9 ISyntax 10 ISyntax-E 11 ISyntax/Non 12 ISyntax/Non-E 13 ISyntax/Non-Stx 14 any->isyntax/non 15 syntax->isyntax/non 16 any->isyntax/non-e 17 try-any->isyntax 18 try-syntax->isyntax 19 try-any->isyntax-e 20 isyntax? 21 isyntax-e?) 22 23 (unsafe-require/typed racket/base 24 [[datum->syntax datum->syntax*] 25 (∀ (A) (→ (Syntaxof Any) 26 A 27 (Syntaxof Any) 28 (Syntaxof Any) 29 (Syntaxof A)))] 30 ;; Backported from 6.8 so that it works on 6.7 31 [vector->list 32 (∀ (A) (case→ (→ (Vectorof A) (Listof A)) 33 (→ VectorTop (Listof Any))))]) 34 35 (unsafe-require/typed racket/function 36 [[identity unsafe-cast-function] (∀ (A) (→ Any A))]) 37 (define-syntax-rule (unsafe-cast v t) 38 ((inst unsafe-cast-function t) v)) 39 40 (define-type (ISyntaxOf A B) 41 (Rec 42 stx 43 (U A 44 (Syntaxof 45 (U B 46 Boolean 47 Char 48 Complex 49 Keyword 50 String 51 Symbol 52 (Boxof stx) 53 Null 54 (Pairof stx (Rec L (U Null 55 stx 56 (Pairof stx L)))) 57 (Vectorof stx)))))) 58 59 (define-type (ISyntaxOf-E A B) 60 (U B 61 Boolean 62 Char 63 Complex 64 Keyword 65 String 66 Symbol 67 (Boxof (ISyntaxOf A B)) 68 Null 69 (Pairof (ISyntaxOf A B) (Rec L (U Null 70 (ISyntaxOf A B) 71 (Pairof (ISyntaxOf A B) L)))) 72 (Vectorof (ISyntaxOf A B)))) 73 74 (define-type ISyntax/Non (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any))) 75 (define-type ISyntax/Non-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any))) 76 (define-type ISyntax/Non-Stx (Syntaxof ISyntax/Non-E)) 77 78 (define-type ISyntax (ISyntaxOf Nothing Nothing)) 79 (define-type ISyntax-E (ISyntaxOf-E Nothing Nothing)) 80 81 (define-type (Result A) (U (Pairof A (U 'modified 'unmodified)) 82 (Pairof #f #f))) 83 (define Result#f (cons #f #f)) 84 85 (: syntax->isyntax* (∀ (A B) (→ (Syntaxof Any) 86 (→ Any (Result A)) 87 (→ Any (Result B)) 88 (U (Result (Syntaxof (ISyntaxOf-E A B))))))) 89 (define (syntax->isyntax* stx nstx nsexp) 90 (define e (syntax-e stx)) 91 (match-define (cons e* status) (any->isyntax-e* e nstx nsexp)) 92 (case status 93 [(unmodified) 94 (cons (unsafe-cast e (Syntaxof (ISyntaxOf-E A B))) 'unmodified)] 95 [(modified) 96 (cons (datum->syntax* stx e* stx stx) 'modified)] 97 [(#f) 98 Result#f])) 99 100 (: any->isyntax* (∀ (A B) (→ Any 101 (→ Any (Result A)) 102 (→ Any (Result B)) 103 (Result (ISyntaxOf A B))))) 104 (define (any->isyntax* e nstx nsexp) 105 (if (syntax? e) 106 (syntax->isyntax* e nstx nsexp) 107 (nstx e))) 108 109 (: listof-any->listof-isyntax 110 (∀ (A B) (→ (Listof Any) 111 (→ Any (Result A)) 112 (→ Any (Result B)) 113 (Result (Listof (ISyntaxOf A B)))))) 114 (define (listof-any->listof-isyntax e nstx nsexp) 115 (define e*+status 116 (foldr (λ ([eᵢ : Any] [acc : (Result (Listof (ISyntaxOf A B)))]) 117 (match-let ([(cons eᵢ* status) (any->isyntax* eᵢ nstx nsexp)]) 118 (cond 119 [(and (eq? status 'unmodified) 120 (eq? (cdr acc) 'unmodified)) 121 (cons (cons eᵢ* (car acc)) 'unmodified)] 122 [(or (eq? status #f) 123 (eq? (cdr acc) #f)) 124 Result#f] 125 [else 126 (cons (cons eᵢ* (car acc)) 'modified)]))) 127 (cons '() 'unmodified) 128 e)) 129 (define e* (car e*+status)) 130 (define status (cdr e*+status)) 131 (case status 132 [(unmodified) (cons (unsafe-cast e (Listof (ISyntaxOf A B))) 'unmodified)] 133 [(modified) (cons e* 'modified)] 134 [(#f) Result#f])) 135 136 #;(: handle-pair (case→ (→ (Listof Any) 137 (Values (Listof Syntax-E) 138 (U 'unmodified 'modified))) 139 (→ (Pairof Any (Rec L (U Any (Pairof Any L)))) 140 (Values (Pairof Syntax-E 141 (Rec L (U Syntax-E 142 (Pairof Syntax-E L)))) 143 (U 'unmodified 'modified))) 144 (→ Any 145 (Values ISyntax 146 (U 'unmodified 'modified))))) 147 #;(: handle-pair (case→ (→ (Pairof Any (Listof Any)) 148 (Values (Listof Syntax-E) 149 (U 'unmodified 'modified))) 150 (→ (Pairof Any (Rec L (U Any (Pairof Any L)))) 151 (Values (Pairof Syntax-E 152 (Rec L (U Syntax-E 153 (Pairof Syntax-E L)))) 154 (U 'unmodified 'modified))))) 155 (: handle-pair (∀ (A B) (→ (U (Pairof Any (Listof Any)) 156 (Pairof Any (Rec L (U Any (Pairof Any L))))) 157 (→ Any (Result A)) 158 (→ Any (Result B)) 159 (Result (Pairof (ISyntaxOf A B) 160 (Rec L (U (ISyntaxOf A B) 161 Null 162 (Pairof (ISyntaxOf A B) 163 L)))))))) 164 (define (handle-pair e nstx nsexp) 165 (define car*+status (any->isyntax* (car e) nstx nsexp)) 166 (define car* (car car*+status)) 167 (define status-car (cdr car*+status)) 168 (cond 169 [(pair? (cdr e)) 170 (match-let ([(cons cdr* status-cdr) 171 (handle-pair (cdr e) nstx nsexp)]) 172 (cond 173 #;[(and (eq? status-car 'unmodified) 174 (eq? status-cdr 'unmodified)) 175 (cons (unsafe-cast e (Pairof ISyntax 176 (Rec L (U ISyntax 177 Null 178 (Pairof ISyntax L))))) 179 'unmodified)] 180 [(or (eq? status-car #f) 181 (eq? status-cdr #f)) 182 Result#f] 183 [else 184 (cons (cons car* cdr*) 'modified)]))] 185 [(null? (cdr e)) 186 (cond 187 #;[(eq? status-car 'unmodified) 188 (cons (unsafe-cast e (Pairof ISyntax Null)) 'unmodified)] 189 [(eq? status-car #f) 190 Result#f] 191 [else 192 (cons (ann (cons car* (cdr e)) 193 (Pairof (ISyntaxOf A B) 194 (Rec L (U (ISyntaxOf A B) 195 Null 196 (Pairof (ISyntaxOf A B) 197 L))))) 198 'modified)])] 199 [else 200 (match-let ([(cons cdr* status-cdr) (any->isyntax* (cdr e) nstx nsexp)]) 201 (cond 202 #;[(and (eq? status-car 'unmodified) 203 (eq? status-cdr 'unmodified)) 204 (cons (unsafe-cast e (Pairof ISyntax 205 (Rec L (U ISyntax 206 Null 207 (Pairof ISyntax L))))) 208 'unmodified)] 209 [(or (eq? status-car #f) 210 (eq? status-cdr #f)) 211 Result#f] 212 [else 213 (cons (cons car* cdr*) 'modified)]))])) 214 215 (: any->isyntax-e* (∀ (A B) (→ Any 216 (→ Any (Result A)) 217 (→ Any (Result B)) 218 (Result (ISyntaxOf-E A B))))) 219 (define (any->isyntax-e* e nstx nsexp) 220 (cond 221 [(boolean? e) (cons e 'unmodified)] 222 [(char? e) (cons e 'unmodified)] 223 [(number? e) (cons e 'unmodified)] 224 [(keyword? e) (cons e 'unmodified)] 225 [(null? e) (cons e 'unmodified)] 226 [(string? e) (if (immutable? e) 227 (cons e 'unmodified) 228 (cons (string->immutable-string e) 'modified))] 229 [(symbol? e) (cons e 'unmodified)] 230 [(box? e) (match-let ([(cons u* status) (any->isyntax* (unbox e) nstx nsexp)]) 231 (case status 232 [(unmodified) 233 ;(if (immutable? e) 234 ;(values (unsafe-cast e (Sexpof A)) 'unmodified) 235 (cons (box-immutable u*) 'modified);) 236 ] 237 [(modified) 238 (cons (box-immutable u*) 'modified)] 239 [(#f) 240 Result#f]))] 241 [(pair? e) (handle-pair e nstx nsexp)] 242 [(vector? e) (match-let ([(cons vs* status) 243 (listof-any->listof-isyntax (vector->list e) nstx nsexp)]) 244 (case status 245 [(unmodified) 246 (if (immutable? e) 247 (cons (unsafe-cast e (ISyntaxOf-E A B)) 248 'unmodified) 249 (cons (apply vector-immutable vs*) 250 'modified))] 251 [(modified) 252 (cons (apply vector-immutable vs*) 'modified)] 253 [(#f) 254 Result#f]))] 255 [else 256 (nsexp e)])) 257 258 (: any->isyntax/non (→ Any ISyntax/Non)) 259 (define (any->isyntax/non e) 260 (define e*+status 261 (any->isyntax* e 262 (λ (n) (cons (NonSyntax n) 'modified)) 263 (λ (n) (cons (NonSexp n) 'modified)))) 264 (if (cdr e*+status) 265 (car e*+status) 266 (error "Got #f from any->isyntax* with handlers not returning #f"))) 267 268 (: syntax->isyntax/non (→ (Syntaxof Any) (Syntaxof ISyntax/Non-E))) 269 (define (syntax->isyntax/non stx) 270 (define e*+status 271 (syntax->isyntax* stx 272 (λ (n) (cons (NonSyntax n) 'modified)) 273 (λ (n) (cons (NonSexp n) 'modified)))) 274 (if (cdr e*+status) 275 (car e*+status) 276 (error "Got #f from any->isyntax* with handlers not returning #f"))) 277 278 (: any->isyntax/non-e (→ Any ISyntax/Non-E)) 279 (define (any->isyntax/non-e e) 280 (define e*+status 281 (any->isyntax-e* e 282 (λ (n) (cons (NonSyntax n) 'modified)) 283 (λ (n) (cons (NonSexp n) 'modified)))) 284 (if (cdr e*+status) 285 (car e*+status) 286 (error "Got #f from any->isyntax* with handlers not returning #f"))) 287 288 (: try-any->isyntax (→ Any (Maybe ISyntax))) 289 (define (try-any->isyntax e) 290 (define e*+status 291 ((inst any->isyntax* Nothing Nothing) e 292 (λ (n) Result#f) 293 (λ (n) Result#f))) 294 (if (cdr e*+status) 295 (Some (car e*+status)) 296 #f)) 297 298 (: try-syntax->isyntax (→ (Syntaxof Any) (Maybe (Syntaxof ISyntax-E)))) 299 (define (try-syntax->isyntax stx) 300 (define e*+status 301 ((inst syntax->isyntax* Nothing Nothing) stx 302 (λ (n) Result#f) 303 (λ (n) Result#f))) 304 (if (cdr e*+status) 305 (Some (car e*+status)) 306 #f)) 307 308 (: try-any->isyntax-e (→ Any (Maybe ISyntax-E))) 309 (define (try-any->isyntax-e e) 310 (define e*+status 311 ((inst any->isyntax-e* Nothing Nothing) e 312 (λ (n) Result#f) 313 (λ (n) Result#f))) 314 (if (cdr e*+status) 315 (Some (car e*+status)) 316 #f)) 317 318 (define isyntax? 319 (unsafe-cast (λ ([e : Any]) : Boolean 320 (define e*+status 321 ((inst any->isyntax* Nothing Nothing) e 322 (λ (n) Result#f) 323 (λ (n) Result#f))) 324 (eq? (cdr e*+status) 'unmodified)) 325 (→ Any Boolean : ISyntax))) 326 327 (define isyntax-e? 328 (unsafe-cast (λ ([e : Any]) : Boolean 329 (define e*+status 330 ((inst any->isyntax-e* Nothing Nothing) e 331 (λ (n) Result#f) 332 (λ (n) Result#f))) 333 (eq? (cdr e*+status) 'unmodified)) 334 (→ Any Boolean : ISyntax-E)))