1(module module-reader racket/private/base 2 (require syntax/readerr 3 (for-syntax racket/private/base)) 4 5 (provide (rename-out [provide-module-reader #%module-begin] 6 [wrap wrap-read-all]) 7 make-meta-reader 8 lang-reader-module-paths 9 (except-out (all-from-out racket/private/base) #%module-begin)) 10 11 (define ar? procedure-arity-includes?) 12 13 (define-syntax (provide-module-reader stx) 14 (define (err str [sub #f]) 15 (raise-syntax-error 'syntax/module-reader str sub)) 16 (define-syntax-rule (keywords body [kwd var default] ... [checks ...]) 17 (begin 18 (define var #f) ... 19 (set! body 20 (let loop ([body body]) 21 (if (not (and (pair? body) 22 (pair? (cdr body)) 23 (keyword? (syntax-e (car body))))) 24 (datum->syntax stx body stx) 25 (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) 26 (case k* 27 [(kwd) (if var 28 (err (format "got two ~s keywords" k*) k) 29 (begin (set! var v) (loop (cddr body))))] 30 ... 31 [else (err "got an unknown keyword" (car body))]))))) 32 checks ... 33 (unless var (set! var default)) ...)) 34 (define <lang-id> (datum->syntax stx 'language-module stx)) 35 (define <data-id> (datum->syntax stx 'language-data stx)) 36 (define (construct-reader lang body) 37 (keywords body 38 [#:language ~lang lang] 39 [#:read ~read #'read] 40 [#:read-syntax ~read-syntax #'read-syntax] 41 [#:wrapper1 ~wrapper1 #'#f] 42 [#:wrapper2 ~wrapper2 #'#f] 43 [#:module-wrapper ~module-wrapper #'#f] 44 [#:whole-body-readers? ~whole-body-readers? #'#f] 45 [#:info ~info #'#f] 46 [#:language-info ~module-get-info #'#f] 47 [(when (equal? (and lang #t) (and ~lang #t)) 48 (err (string-append 49 "must specify either a module language, or #:language" 50 (if (and lang ~lang) ", not both" "")))) 51 (unless (equal? (and ~read #t) (and ~read-syntax #t)) 52 (err "must specify either both #:read and #:read-syntax, or none")) 53 (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) 54 (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) 55 ;; FIXME: some generated code is constant and should be lifted out of the 56 ;; template: 57 (quasisyntax/loc stx 58 (#%module-begin 59 #,@body 60 (#%provide (rename lang:read read) 61 (rename lang:read-syntax read-syntax) 62 get-info) 63 (define (lang:read in modpath line col pos) 64 (wrap-internal/wrapper #f #f in modpath line col pos)) 65 (define (lang:read-syntax src in modpath line col pos) 66 (wrap-internal/wrapper #t src in modpath line col pos)) 67 (define (wrap-internal/wrapper stx? src in modpath line col pos) 68 (let* ([props (read-properties in modpath line col pos)] 69 [lang (car props)] [#,<lang-id> lang] ;\ visible in 70 [data (cadr props)] [#,<data-id> data] ;/ user-code 71 [read (if stx? 72 (let ([rd #,~read-syntax]) 73 (lambda (in) (rd src in))) 74 #,~read)] 75 [w1 #,~wrapper1] 76 [w2 #,~wrapper2] 77 [mw #,~module-wrapper] 78 [whole? #,~whole-body-readers?] 79 [rd (lambda (in) 80 (wrap-internal (if (and (not stx?) (syntax? lang)) 81 (syntax->datum lang) 82 lang) 83 in read whole? w1 stx? 84 modpath src line col pos))]) 85 ((or (and mw 86 (if (procedure-arity-includes? mw 2) 87 mw 88 (lambda (thunk stx?) (mw thunk)))) 89 (lambda (thunk stx?) (thunk))) 90 (lambda () 91 (let ([r (cond [(not w2) (rd in)] 92 [(ar? w2 3) (w2 in rd stx?)] 93 [else (w2 in rd)])]) 94 (if stx? 95 (let ([prop #,(if (syntax-e ~module-get-info) 96 ~module-get-info 97 #'#f)]) 98 (if prop 99 (syntax-property r 'module-language prop) 100 r)) 101 r))) 102 stx?))) 103 (define read-properties (lang->read-properties #,~lang)) 104 (define (get-info in modpath line col pos) 105 (get-info-getter (read-properties in modpath line col pos))) 106 (define (get-info-getter props) 107 (define lang (car props)) 108 (define data (cadr props)) 109 (define (default-info what defval) 110 (case what 111 [(module-language) lang] 112 ;; ... more? 113 [else defval])) 114 (define info 115 (let* ([#,<lang-id> lang] ;\ visible in 116 [#,<data-id> data] ;/ user-code 117 [info #,~info]) 118 (if (or (not info) (and (procedure? info) (ar? info 3))) 119 info 120 (raise-type-error 'syntax/module-reader 121 "info procedure of 3 arguments" info)))) 122 (define (language-info what defval) 123 (if info 124 (let ([r (info what defval default-info)]) 125 (if (eq? r default-info) (default-info what defval) r)) 126 (default-info what defval))) 127 language-info)))) 128 (syntax-case stx () 129 [(_ lang body ...) 130 (not (keyword? (syntax-e #'lang))) 131 (construct-reader #''lang (syntax->list #'(body ...)))] 132 [(_ body ...) (construct-reader #f (syntax->list #'(body ...)))])) 133 134 ;; turns the language specification (either a language or some flavor of a 135 ;; function that returns a language and some properties) into a function that 136 ;; returns (list <lang> <props>) 137 (define (lang->read-properties lang) 138 (define lang* 139 (cond [(not (procedure? lang)) (list lang #f)] 140 [(ar? lang 5) lang] 141 [(ar? lang 1) (lambda (in . _) (lang in))] 142 [(ar? lang 0) (lambda _ (lang))] 143 [else (raise-type-error 144 'syntax/module-reader 145 "language+reader procedure of 5, 1, or 0 arguments" 146 lang)])) 147 (define (read-properties in modpath line col pos) 148 (if (not (procedure? lang*)) 149 lang* 150 (parameterize ([current-input-port in]) 151 (call-with-values 152 (lambda () (lang* in modpath line col pos)) 153 (lambda xs 154 (case (length xs) 155 [(2) xs] [(1) (list (car xs) #f)] 156 [else (error 'syntax/module-reader 157 "wrong number of results from ~a, ~a ~e" 158 "the #:language function" 159 "expected 1 or 2 values, got" 160 (length xs))])))))) 161 read-properties) 162 163 ;; Since there are users that wrap with `#%module-begin' in their reader 164 ;; or wrapper1 functions, we need to avoid double-wrapping. Having to do 165 ;; this for #lang readers should be considered deprecated, and hopefully 166 ;; one day we'll move to just doing it unilaterally (making this code throw 167 ;; an error in that case before that's done). 168 ;; This function takes "body" as a sequence of expressions (can be syntaxes 169 ;; and/or sexprs) and returns a new body as a *single* expression that is 170 ;; wrapped in a `#%module-begin' -- using the input if it was a single 171 ;; pre-wrapped expression. 172 (define (wrap-module-begin body) 173 (let ([exprs (if (syntax? body) (syntax->list body) body)]) 174 (if (and (pair? exprs) (null? (cdr exprs)) 175 (let* ([x (car exprs)] 176 [x (if (syntax? x) (syntax-e x) x)] 177 [x (and (pair? x) (car x))] 178 [x (if (syntax? x) (syntax-e x) x)]) 179 (eq? x '#%module-begin))) 180 (car exprs) 181 (cons '#%module-begin body)))) 182 183 (define (wrap-internal lang port read whole? wrapper stx? 184 modpath src line col pos) 185 (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)] 186 [body (lambda () 187 (if whole? 188 (read port) 189 (parameterize ([read-accept-lang #f]) 190 (let loop ([a null]) 191 (let ([v (read port)]) 192 (if (eof-object? v) 193 (reverse a) 194 (loop (cons v a))))))))] 195 [body (cond [(not wrapper) (body)] 196 [(ar? wrapper 2) (wrapper body stx?)] 197 [else (wrapper body)])] 198 [body (wrap-module-begin body)] 199 [all-loc (vector src line col pos 200 (let-values ([(l c p) (port-next-location port)]) 201 (and p pos (max 0 (- p pos)))))] 202 [p-name (object-name port)] 203 [name (if (path? p-name) 204 (let-values ([(base name dir?) (split-path p-name)]) 205 (string->symbol 206 (path->string (path-replace-extension name #"")))) 207 'anonymous-module)] 208 [tag-src (lambda (v) 209 (if stx? 210 (datum->syntax 211 #f v (vector src line col pos 212 (and pos (max 0 213 (- (or (syntax-position modpath) 214 (add1 pos)) 215 pos))))) 216 v))] 217 [r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)]) 218 (if stx? (datum->syntax #f r all-loc) r))) 219 220 (define (wrap lang port read modpath src line col pos) 221 (wrap-internal lang port read #f #f #f modpath src line col pos)) 222 223 (define (make-meta-reader 224 self-sym module-path-desc spec->module-path 225 convert-read 226 convert-read-syntax 227 convert-get-info 228 #:read-spec 229 [read-spec 230 (lambda (in) 231 (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) ;; if this changes, the regexp in planet's lang/reader.rkt must also change 232 (and spec (let ([s (cadr spec)]) 233 (if (equal? s "") #f s)))))]) 234 (define (peek-leading-spaces in) 235 (let ([m (regexp-match-peek #px"^[ \t]+" in)]) 236 (if m (bytes-length (car m)) 0))) 237 (define (get in export-sym src line col pos spec-as-stx? mk-fail-thunk) 238 (define (bad str eof?) 239 ((if eof? raise-read-eof-error raise-read-error) 240 (let ([msg (format "bad ~a following ~a" module-path-desc self-sym)]) 241 (if str (format "~a: ~a" msg str) msg)) 242 src line col pos 243 (let-values ([(line col pos2) (port-next-location in)]) 244 (and pos pos2 (- pos2 pos))))) 245 (let*-values ([(spec-line spec-col spec-pos) (port-next-location in)] 246 [(leading-spaces) (peek-leading-spaces in)] 247 [(spec-col) (and spec-col (+ spec-col leading-spaces))] 248 [(spec-pos) (and spec-pos (+ spec-pos leading-spaces))] 249 [(spec) (read-spec in)] 250 [(_line _col spec-end-pos) (port-next-location in)]) 251 (if (not spec) 252 (bad #f (eof-object? (peek-byte in))) 253 (let ([parsed-spec (spec->module-path spec)]) 254 (if parsed-spec 255 (let loop ([specs (if (vector? parsed-spec) 256 (vector->list parsed-spec) 257 (list parsed-spec))]) 258 (define parsed-spec (car specs)) 259 (define guarded-spec ((current-reader-guard) parsed-spec)) 260 (if (or (null? (cdr specs)) 261 (module-declared? guarded-spec #t)) 262 (values 263 (dynamic-require guarded-spec export-sym 264 (mk-fail-thunk spec)) 265 (if spec-as-stx? 266 (datum->syntax #f 267 guarded-spec 268 (vector src spec-line spec-col spec-pos 269 (max 0 (- spec-end-pos spec-pos))) 270 ;; get syntax with `syntax-original?` property: 271 (call-with-default-reading-parameterization 272 (lambda () 273 (read-syntax 'orig (open-input-bytes #"x"))))) 274 guarded-spec)) 275 (loop (cdr specs)))) 276 (bad spec #f)))))) 277 278 (define (-get-info inp mod line col pos) 279 (let-values ([(r next-mod) 280 (get inp 'get-info (object-name inp) line col pos #f 281 (lambda (spec) 282 (lambda () 283 (lambda (inp mod line col pos) 284 (lambda (tag defval) defval)))))]) 285 (convert-get-info (r inp next-mod line col pos)))) 286 287 (define (read-fn in read-sym args src mod line col pos convert) 288 (let-values ([(r next-mod) 289 (get in read-sym src #|mod|# line col pos 290 (eq? read-sym 'read-syntax) 291 (lambda (spec) 292 (lambda () 293 (error read-sym "cannot find reader for `#lang ~a ~s'" 294 self-sym 295 spec))))]) 296 (let ([r (convert r)]) 297 (if (and (procedure? r) 298 (procedure-arity-includes? r (+ 5 (length args)))) 299 (apply r (append args (list in next-mod line col pos))) 300 (apply r (append args (list in))))))) 301 302 (define (-read inp mod line col pos) 303 (read-fn inp 'read null (object-name inp) mod line col pos 304 convert-read)) 305 306 (define (-read-syntax src inp mod line col pos) 307 (read-fn inp 'read-syntax (list src) src mod line col pos 308 convert-read-syntax)) 309 310 (values -read -read-syntax -get-info)) 311 312 ;; lang-reader-module-paths : Byte-String -> (U False (Vectorof Module-Path)) 313 ;; To be used as the third argument to make-meta-reader in lang-extensions 314 ;; like at-exp. On success, returns a vector of module paths, one of which 315 ;; should point to the reader module for the #lang bstr language. 316 (define (lang-reader-module-paths bstr) 317 (let* ([str (bytes->string/latin-1 bstr)] 318 [sym (string->symbol str)]) 319 (and (module-path? sym) 320 (vector 321 ;; try submod first: 322 `(submod ,sym reader) 323 ;; fall back to /lang/reader: 324 (string->symbol (string-append str "/lang/reader")))))) 325 326 ) 327