283 lines
13 KiB
Racket
283 lines
13 KiB
Racket
(module module-reader racket/private/base
|
|
(require syntax/readerr
|
|
(for-syntax racket/private/base))
|
|
|
|
(provide (rename-out [provide-module-reader #%module-begin]
|
|
[wrap wrap-read-all])
|
|
make-meta-reader
|
|
(except-out (all-from-out racket/private/base) #%module-begin))
|
|
|
|
(define ar? procedure-arity-includes?)
|
|
|
|
(define-syntax (provide-module-reader stx)
|
|
(define (err str [sub #f])
|
|
(raise-syntax-error 'syntax/module-reader str sub))
|
|
(define-syntax-rule (keywords body [kwd var default] ... [checks ...])
|
|
(begin
|
|
(define var #f) ...
|
|
(set! body
|
|
(let loop ([body body])
|
|
(if (not (and (pair? body)
|
|
(pair? (cdr body))
|
|
(keyword? (syntax-e (car body)))))
|
|
(datum->syntax stx body stx)
|
|
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
|
|
(case k*
|
|
[(kwd) (if var
|
|
(err (format "got two ~s keywords" k*) k)
|
|
(begin (set! var v) (loop (cddr body))))]
|
|
...
|
|
[else (err "got an unknown keyword" (car body))])))))
|
|
checks ...
|
|
(unless var (set! var default)) ...))
|
|
(define <lang-id> (datum->syntax stx 'language-module stx))
|
|
(define <data-id> (datum->syntax stx 'language-data stx))
|
|
(define (construct-reader lang body)
|
|
(keywords body
|
|
[#:language ~lang lang]
|
|
[#:read ~read #'read]
|
|
[#:read-syntax ~read-syntax #'read-syntax]
|
|
[#:wrapper1 ~wrapper1 #'#f]
|
|
[#:wrapper2 ~wrapper2 #'#f]
|
|
[#:whole-body-readers? ~whole-body-readers? #'#f]
|
|
[#:info ~info #'#f]
|
|
[#:language-info ~module-get-info #'#f]
|
|
[(when (equal? (and lang #t) (and ~lang #t))
|
|
(err (string-append
|
|
"must specify either a module language, or #:language"
|
|
(if (and lang ~lang) ", not both" ""))))
|
|
(unless (equal? (and ~read #t) (and ~read-syntax #t))
|
|
(err "must specify either both #:read and #:read-syntax, or none"))
|
|
(when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
|
|
(err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
|
|
;; FIXME: some generated code is constant and should be lifted out of the
|
|
;; template:
|
|
(quasisyntax/loc stx
|
|
(#%module-begin
|
|
#,@body
|
|
(#%provide (rename lang:read read)
|
|
(rename lang:read-syntax read-syntax)
|
|
get-info)
|
|
(define (lang:read in modpath line col pos)
|
|
(wrap-internal/wrapper #f #f in modpath line col pos))
|
|
(define (lang:read-syntax src in modpath line col pos)
|
|
(wrap-internal/wrapper #t src in modpath line col pos))
|
|
(define (wrap-internal/wrapper stx? src in modpath line col pos)
|
|
(let* ([props (read-properties in modpath line col pos)]
|
|
[lang (car props)] [#,<lang-id> lang] ;\ visible in
|
|
[data (cadr props)] [#,<data-id> data] ;/ user-code
|
|
[read (if stx?
|
|
(let ([rd #,~read-syntax])
|
|
(lambda (in) (rd src in)))
|
|
#,~read)]
|
|
[w1 #,~wrapper1]
|
|
[w2 #,~wrapper2]
|
|
[whole? #,~whole-body-readers?]
|
|
[rd (lambda (in)
|
|
(wrap-internal (if (and (not stx?) (syntax? lang))
|
|
(syntax->datum lang)
|
|
lang)
|
|
in read whole? w1 stx?
|
|
modpath src line col pos))]
|
|
[r (cond [(not w2) (rd in)]
|
|
[(ar? w2 3) (w2 in rd stx?)]
|
|
[else (w2 in rd)])])
|
|
(if stx?
|
|
(let ([prop #,(if (syntax-e ~module-get-info)
|
|
~module-get-info
|
|
#'#f)])
|
|
(if prop
|
|
(syntax-property r 'module-language prop)
|
|
r))
|
|
r)))
|
|
(define read-properties (lang->read-properties #,~lang))
|
|
(define (get-info in modpath line col pos)
|
|
(get-info-getter (read-properties in modpath line col pos)))
|
|
(define (get-info-getter props)
|
|
(define lang (car props))
|
|
(define data (cadr props))
|
|
(define (default-info what defval)
|
|
(case what
|
|
[(module-language) lang]
|
|
;; ... more?
|
|
[else defval]))
|
|
(define info
|
|
(let* ([#,<lang-id> lang] ;\ visible in
|
|
[#,<data-id> data] ;/ user-code
|
|
[info #,~info])
|
|
(if (or (not info) (and (procedure? info) (ar? info 3)))
|
|
info
|
|
(raise-type-error 'syntax/module-reader
|
|
"info procedure of 3 arguments" info))))
|
|
(define (language-info what defval)
|
|
(if info
|
|
(let ([r (info what defval default-info)])
|
|
(if (eq? r default-info) (default-info what defval) r))
|
|
(default-info what defval)))
|
|
language-info))))
|
|
(syntax-case stx ()
|
|
[(_ lang body ...)
|
|
(not (keyword? (syntax-e #'lang)))
|
|
(construct-reader #''lang (syntax->list #'(body ...)))]
|
|
[(_ body ...) (construct-reader #f (syntax->list #'(body ...)))]))
|
|
|
|
;; turns the language specification (either a language or some flavor of a
|
|
;; function that returns a language and some properties) into a function that
|
|
;; returns (list <lang> <props>)
|
|
(define (lang->read-properties lang)
|
|
(define lang*
|
|
(cond [(not (procedure? lang)) (list lang #f)]
|
|
[(ar? lang 5) lang]
|
|
[(ar? lang 1) (lambda (in . _) (lang in))]
|
|
[(ar? lang 0) (lambda _ (lang))]
|
|
[else (raise-type-error
|
|
'syntax/module-reader
|
|
"language+reader procedure of 5, 1, or 0 arguments"
|
|
lang)]))
|
|
(define (read-properties in modpath line col pos)
|
|
(if (not (procedure? lang*))
|
|
lang*
|
|
(parameterize ([current-input-port in])
|
|
(call-with-values
|
|
(lambda () (lang* in modpath line col pos))
|
|
(lambda xs
|
|
(case (length xs)
|
|
[(2) xs] [(1) (list (car xs) #f)]
|
|
[else (error 'syntax/module-reader
|
|
"wrong number of results from ~a, ~a ~e"
|
|
"the #:language function"
|
|
"expected 1 or 2 values, got"
|
|
(length xs))]))))))
|
|
read-properties)
|
|
|
|
;; Since there are users that wrap with `#%module-begin' in their reader
|
|
;; or wrapper1 functions, we need to avoid double-wrapping. Having to do
|
|
;; this for #lang readers should be considered deprecated, and hopefully
|
|
;; one day we'll move to just doing it unilaterally (making this code throw
|
|
;; an error in that case before that's done).
|
|
;; This function takes "body" as a sequence of expressions (can be syntaxes
|
|
;; and/or sexprs) and returns a new body as a *single* expression that is
|
|
;; wrapped in a `#%module-begin' -- using the input if it was a single
|
|
;; pre-wrapped expression.
|
|
(define (wrap-module-begin body)
|
|
(let ([exprs (if (syntax? body) (syntax->list body) body)])
|
|
(if (and (pair? exprs) (null? (cdr exprs))
|
|
(let* ([x (car exprs)]
|
|
[x (if (syntax? x) (syntax-e x) x)]
|
|
[x (and (pair? x) (car x))]
|
|
[x (if (syntax? x) (syntax-e x) x)])
|
|
(eq? x '#%module-begin)))
|
|
(car exprs)
|
|
(cons '#%module-begin body))))
|
|
|
|
(define (wrap-internal lang port read whole? wrapper stx?
|
|
modpath src line col pos)
|
|
(let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)]
|
|
[body (lambda ()
|
|
(if whole?
|
|
(read port)
|
|
(let loop ([a null])
|
|
(let ([v (read port)])
|
|
(if (eof-object? v)
|
|
(reverse a)
|
|
(loop (cons v a)))))))]
|
|
[body (cond [(not wrapper) (body)]
|
|
[(ar? wrapper 2) (wrapper body stx?)]
|
|
[else (wrapper body)])]
|
|
[body (wrap-module-begin body)]
|
|
[all-loc (vector src line col pos
|
|
(let-values ([(l c p) (port-next-location port)])
|
|
(and p (- p pos))))]
|
|
[p-name (object-name port)]
|
|
[name (if (path? p-name)
|
|
(let-values ([(base name dir?) (split-path p-name)])
|
|
(string->symbol
|
|
(path->string (path-replace-suffix name #""))))
|
|
'anonymous-module)]
|
|
[tag-src (lambda (v)
|
|
(if stx?
|
|
(datum->syntax
|
|
#f v (vector src line col pos
|
|
(- (or (syntax-position modpath)
|
|
(add1 pos))
|
|
pos)))
|
|
v))]
|
|
[r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)])
|
|
(if stx? (datum->syntax #f r all-loc) r)))
|
|
|
|
(define (wrap lang port read modpath src line col pos)
|
|
(wrap-internal lang port read #f #f #f modpath src line col pos))
|
|
|
|
(define (make-meta-reader
|
|
self-sym module-path-desc spec->module-path
|
|
convert-read
|
|
convert-read-syntax
|
|
convert-get-info
|
|
#:read-spec
|
|
[read-spec
|
|
(lambda (in)
|
|
(let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) ;; if this changes, the regexp in planet's lang/reader.ss must also change
|
|
(and spec (let ([s (cadr spec)])
|
|
(if (equal? s "") #f s)))))])
|
|
(define (get in export-sym src line col pos spec-as-stx? mk-fail-thunk)
|
|
(define (bad str eof?)
|
|
((if eof? raise-read-eof-error raise-read-error)
|
|
(let ([msg (format "bad ~a following ~a" module-path-desc self-sym)])
|
|
(if str (format "~a: ~a" msg str) msg))
|
|
src line col pos
|
|
(let-values ([(line col pos2) (port-next-location in)])
|
|
(and pos pos2 (- pos2 pos)))))
|
|
(let*-values ([(spec-line spec-col spec-pos) (port-next-location in)]
|
|
[(spec) (read-spec in)]
|
|
[(spec-end-line spec-end-col spec-end-pos) (port-next-location in)])
|
|
(if (not spec)
|
|
(bad #f (eof-object? (peek-byte in)))
|
|
(let ([parsed-spec (spec->module-path spec)])
|
|
(if parsed-spec
|
|
(begin
|
|
((current-reader-guard) parsed-spec)
|
|
(values
|
|
(dynamic-require parsed-spec export-sym
|
|
(mk-fail-thunk spec))
|
|
(if spec-as-stx?
|
|
(datum->syntax #f
|
|
parsed-spec
|
|
(vector src spec-line spec-col spec-pos
|
|
(- spec-end-pos spec-pos)))
|
|
parsed-spec)))
|
|
(bad spec #f))))))
|
|
|
|
(define (-get-info inp mod line col pos)
|
|
(let-values ([(r next-mod)
|
|
(get inp 'get-info (object-name inp) line col pos #f
|
|
(lambda (spec)
|
|
(lambda ()
|
|
(lambda (inp mod line col pos)
|
|
(lambda (tag defval) defval)))))])
|
|
(convert-get-info (r inp next-mod line col pos))))
|
|
|
|
(define (read-fn in read-sym args src mod line col pos convert)
|
|
(let-values ([(r next-mod)
|
|
(get in read-sym src #|mod|# line col pos
|
|
(eq? read-sym 'read-syntax)
|
|
(lambda (spec)
|
|
(lambda ()
|
|
(error read-sym "cannot find reader for `#lang ~a ~a'"
|
|
self-sym
|
|
spec))))])
|
|
(let ([r (convert r)])
|
|
(if (and (procedure? r)
|
|
(procedure-arity-includes? r (+ 5 (length args))))
|
|
(apply r (append args (list in next-mod line col pos)))
|
|
(apply r (append args (list in)))))))
|
|
|
|
(define (-read inp mod line col pos)
|
|
(read-fn inp 'read null (object-name inp) mod line col pos
|
|
convert-read))
|
|
|
|
(define (-read-syntax src inp mod line col pos)
|
|
(read-fn inp 'read-syntax (list src) src mod line col pos
|
|
convert-read-syntax))
|
|
|
|
(values -read -read-syntax -get-info)))
|