typed-syntax-convert.rkt (5367B)
1 #lang typed/racket 2 3 (require typed-map 4 typed/racket/unsafe 5 "typed-prefab-declarations.rkt") 6 7 (provide try-any->isexp* 8 try-any->isexp 9 any->isexp/non 10 Sexp/Non) 11 12 (define-type Sexp/Non (Sexpof (NonSexpOf Any))) 13 14 (unsafe-require/typed racket/function 15 [[identity unsafe-cast-function] (∀ (A) (→ Any A))]) 16 (unsafe-require/typed racket/base 17 [[datum->syntax datum->syntax*] 18 (∀ (A) (→ (Syntaxof Any) 19 A 20 (Syntaxof Any) 21 (Syntaxof Any) 22 (Syntaxof A)))] 23 ;; Backported from 6.8 so that it works on 6.7 24 [vector->list 25 (∀ (A) (case→ (→ (Vectorof A) (Listof A)) 26 (→ VectorTop (Listof Any))))]) 27 28 (define-syntax-rule (unsafe-cast v t) 29 ((inst unsafe-cast-function t) v)) 30 31 (define-type (non-sexp-handler A) 32 (→ Any 33 (Values (U (Sexpof A) #f) 34 (U 'unmodified 'modified #f)))) 35 36 (: try-listof-any->isexp* (∀ (A) (→ (Listof Any) 37 (non-sexp-handler A) 38 (U (Pairof (Listof (Sexpof A)) 39 (U 'unmodified 'modified)) 40 (Pairof #f #f))))) 41 42 (define (try-listof-any->isexp* e non-sexp) 43 (define e+status* 44 (map (λ ([eᵢ : Any]) 45 (let-values ([(eᵢ* status) (try-any->isexp* eᵢ non-sexp)]) 46 (cons eᵢ* status))) 47 e)) 48 (define e* (map car e+status*)) 49 (define status* (map cdr e+status*)) 50 (cond 51 [(andmap (curry eq? 'unmodified) status*) 52 (cons (unsafe-cast e (Listof (Sexpof A))) 'unmodified)] 53 [(ormap (curry eq? #f) status*) 54 (cons #f #f)] 55 [else 56 (cons e* 'modified)])) 57 58 (: try-any->isexp* (∀ (A) (→ Any 59 (non-sexp-handler A) 60 (Values (U (Sexpof A) #f) 61 (U 'unmodified 'modified #f))))) 62 (define (try-any->isexp* e non-sexp) 63 (cond 64 [(boolean? e) (values e 'unmodified)] 65 [(char? e) (values e 'unmodified)] 66 [(number? e) (values e 'unmodified)] 67 [(keyword? e) (values e 'unmodified)] 68 [(null? e) (values e 'unmodified)] 69 [(string? e) (if (immutable? e) 70 (values e 'unmodified) 71 (values (string->immutable-string e) 'modified))] 72 [(symbol? e) (values e 'unmodified)] 73 [(box? e) (let*-values ([(u) (unbox e)] 74 [(u* status) (try-any->isexp* e non-sexp)]) 75 (case status 76 [(unmodified) 77 (if (immutable? e) 78 (values (unsafe-cast e (Sexpof A)) 'unmodified) 79 (values (box-immutable u*) 'modified))] 80 [(modified) 81 (values (box-immutable u*) 'modified)] 82 [(#f) 83 (values #f #f)]))] 84 [(pair? e) (let*-values ([(car* status-car) 85 (try-any->isexp* (car e) non-sexp)] 86 [(cdr* status-cdr) 87 (try-any->isexp* (cdr e) non-sexp)]) 88 (cond 89 [(and (eq? status-car 'unmodified) 90 (eq? status-cdr 'unmodified)) 91 (values (unsafe-cast e (Sexpof A)) 'unmodified)] 92 [(or (eq? status-car #f) 93 (eq? status-cdr #f)) 94 (values #f #f)] 95 [else 96 (values (cons car* cdr*) 'modified)]))] 97 [(vector? e) (match-let ([(cons vs* status) 98 (try-listof-any->isexp* (vector->list e) non-sexp)]) 99 (case status 100 [(unmodified) 101 (if (immutable? e) 102 (values (unsafe-cast e (Sexpof A)) 'unmodified) 103 (values (apply vector-immutable vs*) 'modified))] 104 [(modified) 105 (values (apply vector-immutable vs*) 'modified)] 106 [(#f) 107 (values #f #f)]))] 108 [else 109 (non-sexp e)])) 110 111 112 (: any->isexp/non (→ Any (Sexpof (NonSexpOf Any)))) 113 (define (any->isexp/non e) 114 (let*-values ([(e* status) (try-any->isexp* 115 e 116 (λ (non-sexp-e) 117 (values (NonSexp non-sexp-e) 118 'modified)))]) 119 (case status 120 [(unmodified) (unsafe-cast e (Sexpof (NonSexpOf Any)))] 121 [(modified) e*] 122 [(#f) 123 (error 124 (string-append "Got #f from try->any-isexp* using non-sexp which does" 125 " not return #f."))]))) 126 127 128 (: try-any->isexp (→ Any (Maybe Sexp))) 129 (define (try-any->isexp e) 130 (let*-values ([(e* status) (try-any->isexp* 131 e 132 (λ (non-sexp-e) 133 (values #f #f)))]) 134 (case status 135 [(unmodified) (Some (unsafe-cast e Sexp))] 136 [(modified) (Some e*)] 137 [(#f) #f])))