reader.rkt (10732B)
1 #lang racket/base 2 3 (provide make-aful-readtable 4 aful-read 5 aful-read-syntax 6 wrap-reader 7 wrap-reader-unhygienic 8 use-aful-readtable 9 current-arg-string 10 (rename-out 11 [aful-read read] 12 [aful-read-syntax read-syntax]) 13 ) 14 15 (require racket/match 16 rackjure/threading 17 racket/port 18 racket/list 19 racket/function 20 syntax/srcloc 21 hygienic-reader-extension/extend-reader 22 "scribble-enhanced.rkt" 23 phc-toolkit/stx 24 "unhygienic/hygienic-reader-extension--extend-reader--unhygienic.rkt" 25 (for-meta -10 racket/base) 26 (for-meta -9 racket/base) 27 (for-meta -8 racket/base) 28 (for-meta -7 racket/base) 29 (for-meta -6 racket/base) 30 (for-meta -5 racket/base) 31 (for-meta -4 racket/base) 32 (for-meta -3 racket/base) 33 (for-meta -2 racket/base) 34 (for-meta -1 racket/base) 35 (for-meta 0 racket/base) 36 (for-meta 1 racket/base) 37 (for-meta 2 racket/base) 38 (for-meta 3 racket/base) 39 (for-meta 4 racket/base) 40 (for-meta 5 racket/base) 41 (for-meta 6 racket/base) 42 (for-meta 7 racket/base) 43 (for-meta 8 racket/base) 44 (for-meta 9 racket/base) 45 (for-meta 10 racket/base) 46 (for-meta 11 (only-in racket/base #%app make-rename-transformer syntax)) 47 ) 48 49 (module+ test 50 (require rackunit)) 51 52 (define (aful-read [in (current-input-port)] #:arg-str [arg-str (current-arg-string)]) 53 (parameterize ([current-arg-string arg-str]) 54 ((wrap-reader read) in))) 55 56 (define (aful-read-syntax [src (object-name (current-input-port))] [in (current-input-port)] 57 #:arg-str [arg-str (current-arg-string)]) 58 (parameterize ([current-arg-string arg-str]) 59 ((wrap-reader read-syntax) src in))) 60 61 (define (wrap-reader p) 62 (extend-reader p make-aful-readtable)) 63 64 (require syntax/strip-context) 65 (define ((wrap-reader-unhygienic p) . p-args) 66 (strip-context 67 (apply (extend-reader-unhygienic p 68 (λ ([orig-rt (current-readtable)] 69 #:outer-scope outer-scope 70 #:arg-str [arg-str (current-arg-string)]) 71 (make-aful-readtable orig-rt 72 #:outer-scope (λ (stx [mode 'flip]) stx) 73 #:arg-str arg-str)) 74 #:hygiene? #f) 75 p-args))) 76 77 (define (make-aful-readtable [orig-rt (current-readtable)] 78 #:outer-scope outer-scope 79 #:arg-str [arg-str (current-arg-string)]) 80 (define reader-proc (make-reader-proc orig-rt outer-scope #:arg-str arg-str)) 81 (let* ([rt orig-rt] 82 [rt (make-readtable rt #\λ 'dispatch-macro reader-proc)] 83 [rt (make-readtable rt #\f 'dispatch-macro reader-proc)] 84 [rt (make-readtable rt #\l 'dispatch-macro reader-proc)]) 85 rt)) 86 87 (define (use-aful-readtable [orig-rt (current-readtable)] #:arg-str [arg-str (current-arg-string)]) 88 (port-count-lines! (current-input-port)) 89 (current-readtable (make-aful-readtable orig-rt #:outer-scope identity #:arg-str arg-str))) 90 91 (define current-arg-string (make-parameter "%")) 92 93 94 (module+ test 95 (check-equal? (aful-read (open-input-string "#λ(+ % %2)")) 96 '(lambda (%1 %2) 97 (define-syntax % (make-rename-transformer #'%1)) 98 (+ % %2))) 99 (check-equal? (aful-read (open-input-string "#λ(+ _ _2)") #:arg-str "_") 100 '(lambda (_1 _2) 101 (define-syntax _ (make-rename-transformer #'_1)) 102 (+ _ _2))) 103 ) 104 105 106 (define ((make-reader-proc orig-rt outer-scope #:arg-str [arg-str (current-arg-string)]) 107 char in src ln col pos) 108 (parameterize ([current-arg-string arg-str]) 109 (define (unget-normal-read-syntax str src in) 110 (define rt (current-readtable)) 111 (parameterize ([current-readtable orig-rt]) 112 (read-syntax/recursive src (input-port-append #f (open-input-string str) in) #f rt))) 113 (define (peek/read? str in) 114 (and (equal? str (peek-string (string-length str) 0 in)) 115 (read-string (string-length str) in))) 116 (cond [(char=? char #\l) 117 (cond [(peek/read? "ambda" in) 118 (define stx (read-syntax src in)) 119 (parse stx outer-scope 120 #:loc (srcloc src ln col pos (- (source-location-end stx) pos)))] 121 [else (unget-normal-read-syntax "#l" src in)])] 122 [(char=? char #\f) 123 (cond [(peek/read? "n" in) 124 (define stx (read-syntax src in)) 125 (parse stx outer-scope 126 #:loc (srcloc src ln col pos (- (source-location-end stx) pos)))] 127 [(peek/read? "unction" in) 128 (define stx (read-syntax src in)) 129 (parse stx outer-scope 130 #:loc (srcloc src ln col pos (- (source-location-end stx) pos)))] 131 [else (unget-normal-read-syntax "#f" src in)])] 132 [(char=? char #\λ) 133 (define stx (read-syntax src in)) 134 (parse stx outer-scope 135 #:loc (srcloc src ln col pos (- (source-location-end stx) pos)))] 136 ;[else (unget-normal-read-syntax (string #\# char) source in)] 137 [else ;single letter e.g. #λ 138 (define stx (read-syntax src in)) 139 (parse stx outer-scope 140 #:loc (srcloc src ln col pos (- (source-location-end stx) pos)))] 141 ))) 142 143 (define (parse stx outer-scope #:loc [loc stx] #:arg-str [arg-str (current-arg-string)]) 144 (parameterize ([current-arg-string arg-str]) 145 (define (string->id stx . strs) 146 (datum->syntax stx (string->symbol (apply string-append strs)) stx)) 147 (match-define (srcloc src ln col pos spn) (build-source-location loc)) 148 (define stx-pos (syntax-position stx)) 149 (define loc-stx (build-source-location-syntax loc)) 150 (define λ-loc 151 (update-source-location loc-stx 152 #:column (and col (+ col 1)) 153 #:position (and pos (+ pos 1)) 154 #:span (and stx-pos pos (max 0 (- stx-pos pos 1))))) 155 (hygienic-app 156 #:outer-scope outer-scope 157 (lambda (stx*) 158 (with-syntax ([lambda (orig (syntax/loc λ-loc lambda))] 159 [args (parse-args stx* #:arg-str arg-str)] 160 [% (string->id stx* arg-str)] 161 [%1 (string->id stx* arg-str "1")] 162 [body stx*]) 163 (syntax-property 164 (syntax/top-loc loc-stx 165 (lambda args 166 (define-syntax % (make-rename-transformer #'%1)) 167 body)) 168 'scribble-render-as 169 aful-scribble-render) 170 )) 171 stx))) 172 173 (define (orig stx) 174 (syntax-property stx 'original-for-check-syntax #t)) 175 176 (module+ test 177 ;; These test `parse`. See test.rkt for tests of readtable use per se. 178 (define (chk stx) 179 (syntax->datum (parse stx identity))) 180 (check-equal? (chk #'(+)) 181 '(lambda () 182 (define-syntax % (make-rename-transformer #'%1)) 183 (+))) 184 (check-equal? (chk #'(+ 2 %1 %1)) 185 '(lambda (%1) 186 (define-syntax % (make-rename-transformer #'%1)) 187 (+ 2 %1 %1))) 188 (check-equal? (chk #'(+ 2 %3 %2 %1)) 189 '(lambda (%1 %2 %3) 190 (define-syntax % (make-rename-transformer #'%1)) 191 (+ 2 %3 %2 %1))) 192 (check-equal? (chk #'(apply list* % %&)) 193 '(lambda (%1 . %&) 194 (define-syntax % (make-rename-transformer #'%1)) 195 (apply list* % %&))) 196 (check-equal? (parameterize ([current-arg-string "_"]) 197 (chk #'(apply list* _ _&))) 198 '(lambda (_1 . _&) 199 (define-syntax _ (make-rename-transformer #'_1)) 200 (apply list* _ _&)))) 201 202 ;; parse-args : Stx -> KW-Formals-Stx 203 (define (parse-args stx #:arg-str [arg-str (current-arg-string)]) 204 ;; Filter the stxs to those that start with %, 205 ;; find the maximum, find whether there are any 206 ;; keyword arguments or a rest argument, and 207 ;; produce kw-formals based on that. 208 (parameterize ([current-arg-string arg-str]) 209 (define-values (max-num rest? kws) 210 (find-arg-info stx)) 211 (define datum-kw-formals 212 (append (for/list ([n (in-range 1 (add1 max-num))]) 213 (string->symbol (string-append arg-str (number->string n)))) 214 (append* 215 (for/list ([kw (in-list kws)]) 216 (list kw (string->symbol (string-append arg-str "#:" (keyword->string kw)))))) 217 (cond [rest? (string->symbol (string-append arg-str "&"))] 218 [else '()]))) 219 (datum->syntax stx datum-kw-formals stx))) 220 221 ;; find-arg-info : Any -> (Values Natural Boolean (Listof Keyword)) 222 (define (find-arg-info v) 223 (match (maybe-syntax-e v) 224 [(? symbol? sym) (find-arg-info/sym sym)] 225 [(? pair? pair) (find-arg-info/pair pair)] 226 [_ (return)])) 227 228 ;; find-arg-info/sym : Symbol -> (Values Natural Boolean (Listof Keyword)) 229 (define (find-arg-info/sym sym) 230 (define arg-str (current-arg-string)) 231 (define (arg-str? str) 232 (string=? str arg-str)) 233 (define (arg-cs? cs) 234 (arg-str? (~> cs list->string))) 235 (define str (~> sym symbol->string)) 236 (match (~> str string->list) 237 [(list) (return)] 238 [_ #:when (arg-str? str) (return #:max-num 1)] 239 [(list arg-cs ... #\&) 240 #:when (arg-cs? arg-cs) 241 (return #:rest? #t)] 242 [(list* arg-cs ... #\# #\: kw-cs) 243 #:when (arg-cs? arg-cs) 244 (return #:kws (~> kw-cs list->string string->keyword list))] 245 [(list arg-cs ... (? char-numeric? n-cs) ...) 246 #:when (arg-cs? arg-cs) 247 (return #:max-num (~> n-cs list->string string->number))] 248 [_ (return)])) 249 250 ;; find-arg-info/pair : 251 ;; (Cons Symbol Symbol) -> (Values Natural Boolean (Listof Keyword)) 252 (define (find-arg-info/pair pair) 253 (define-values (car.max-num car.rest? car.kws) 254 (find-arg-info (car pair))) 255 (define-values (cdr.max-num cdr.rest? cdr.kws) 256 (find-arg-info (cdr pair))) 257 (return #:max-num (max car.max-num cdr.max-num) 258 #:rest? (or car.rest? cdr.rest?) 259 #:kws (remove-duplicates (append car.kws cdr.kws)))) 260 261 (define (return #:max-num [max-num 0] #:rest? [rest? #f] #:kws [kws '()]) 262 (values max-num rest? kws)) 263 264 (define (maybe-syntax-e stx) 265 (cond [(syntax? stx) (syntax-e stx)] 266 [else stx]))