add `pollen/mode` metalang (closes #101)
parent
064107e6f6
commit
5294b02d57
@ -0,0 +1,672 @@
|
||||
;; ============================================================================
|
||||
;; Implements the @-reader macro for embedding text in Racket code.
|
||||
|
||||
#lang racket/base
|
||||
|
||||
(require syntax/readerr)
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; utilities for syntax specifications below
|
||||
|
||||
;; regexps
|
||||
(define (px . args)
|
||||
(let* ([args (let loop ([xs args])
|
||||
(if (list? xs) (apply append (map loop xs)) (list xs)))]
|
||||
[args (map (lambda (x)
|
||||
(cond [(bytes? x) x]
|
||||
[(string? x) (string->bytes/utf-8 x)]
|
||||
[(char? x) (regexp-quote (string->bytes/utf-8 (string x)))]
|
||||
[(not x) #""]
|
||||
[else (internal-error 'px)]))
|
||||
args)])
|
||||
(byte-pregexp (apply bytes-append args))))
|
||||
(define (^px . args) (px #"^" args))
|
||||
|
||||
;; reverses a byte string visually
|
||||
(define reverse-bytes
|
||||
(let ([pairs (let ([xs (bytes->list #"([{<")]
|
||||
[ys (bytes->list #")]}>")])
|
||||
(append (map cons xs ys) (map cons ys xs)))])
|
||||
(define (rev-byte b)
|
||||
(cond [(assq b pairs) => cdr]
|
||||
[else b]))
|
||||
(lambda (bs) (list->bytes (map rev-byte (reverse (bytes->list bs)))))))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; syntax
|
||||
|
||||
;; basic syntax customization
|
||||
(define ch:command #\@)
|
||||
(define ch:comment #\;)
|
||||
(define ch:expr-escape #\|)
|
||||
(define ch:datums-begin #\[)
|
||||
(define ch:datums-end #\])
|
||||
(define ch:lines-begin #\{)
|
||||
(define ch:lines-end #\})
|
||||
|
||||
(define str:lines-begin* #"(\\|[^a-zA-Z0-9 \t\r\n\f@\\\177-\377{]*)\\{")
|
||||
(define str:end-of-line "[ \t]*\r?\n[ \t]*") ; eat spaces on the next line
|
||||
|
||||
;; regexps based on the above (more in make-dispatcher)
|
||||
(define re:whitespaces (^px "\\s+"))
|
||||
(define re:comment-start (^px ch:comment))
|
||||
(define re:comment-line (^px "[^\n]*(?:\n|$)[ \t]*")) ; like tex's `%'
|
||||
(define re:expr-escape (^px ch:expr-escape))
|
||||
(define re:datums-begin (^px ch:datums-begin))
|
||||
(define re:datums-end (^px ch:datums-end))
|
||||
(define re:lines-begin (^px ch:lines-begin))
|
||||
(define re:lines-begin* (^px str:lines-begin*))
|
||||
(define re:lines-end (^px ch:lines-end))
|
||||
(define re:end-of-line (^px str:end-of-line))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; utilities
|
||||
|
||||
(define (internal-error label)
|
||||
(error 'scribble-reader "internal error [~a]" label))
|
||||
|
||||
;; like `regexp-try-match', without extras; the regexp that is used
|
||||
;; must be anchored -- nothing is dropped
|
||||
(define (*regexp-match-peek-positions pattern input-port)
|
||||
#; ; sanity checks, not needed unless this file is edited
|
||||
(unless (and (byte-regexp? pattern)
|
||||
(regexp-match? #rx#"^\\^" (object-name pattern)))
|
||||
(internal-error 'invalid-bregexp))
|
||||
(regexp-match-peek-positions pattern input-port))
|
||||
;; the following doesn't work -- must peek first
|
||||
;; (define (*regexp-match-positions pattern input-port)
|
||||
;; #; ; sanity checks, not needed unless this file is edited
|
||||
;; (unless (and (byte-regexp? pattern)
|
||||
;; (regexp-match? #rx#"^\\^" (object-name pattern)))
|
||||
;; (internal-error 'invalid-bregexp))
|
||||
;; (regexp-match-peek-positions pattern input-port))
|
||||
(define (*regexp-match pattern input-port)
|
||||
(let ([m (*regexp-match-peek-positions pattern input-port)])
|
||||
(and m (let ([s (read-bytes (cdar m) input-port)])
|
||||
(cons s (map (lambda (p) (and p (subbytes s (car p) (cdr p))))
|
||||
(cdr m)))))))
|
||||
;; like regexp-match, but returns the whole match
|
||||
(define (*regexp-match1 pattern input-port)
|
||||
(let ([m (*regexp-match-peek-positions pattern input-port)])
|
||||
(and m (read-bytes (cdar m) input-port))))
|
||||
|
||||
;; Utility for readtable-based caches
|
||||
(define (readtable-cached fun)
|
||||
(let ([cache (make-weak-hasheq)])
|
||||
(letrec ([readtable-cached
|
||||
(case-lambda
|
||||
[(rt) (hash-ref cache rt
|
||||
(lambda ()
|
||||
(let ([r (fun rt)])
|
||||
(hash-set! cache rt r)
|
||||
r)))]
|
||||
[() (readtable-cached (current-readtable))])])
|
||||
readtable-cached)))
|
||||
|
||||
;; Skips whitespace characters, sensitive to the current readtable's
|
||||
;; definition of whitespace; optimizes common spaces when possible
|
||||
(define skip-whitespace
|
||||
(let* ([plain-readtables (make-weak-hasheq)]
|
||||
[plain-spaces " \t\n\r\f"]
|
||||
[plain-spaces-list (string->list " \t\n\r\f")]
|
||||
[plain-spaces-re (^px "[" plain-spaces "]*")])
|
||||
(define (skip-plain-spaces port)
|
||||
;; hack: according to the specs, this might consume more characters
|
||||
;; than needed, but it works fine with a simple <ch>* regexp (because
|
||||
;; it can always match an empty string)
|
||||
(*regexp-match-peek-positions plain-spaces-re port))
|
||||
(define (whitespace? ch rt)
|
||||
(if rt
|
||||
(let-values ([(like-ch/sym _1 _2) (readtable-mapping rt ch)])
|
||||
;; if like-ch/sym is whitespace, then ch is whitespace
|
||||
(and (char? like-ch/sym) (char-whitespace? like-ch/sym)))
|
||||
;; `char-whitespace?' is fine for the default readtable
|
||||
(char-whitespace? ch)))
|
||||
(define plain-readtable?
|
||||
(readtable-cached
|
||||
(lambda (rt)
|
||||
(andmap (lambda (ch) (whitespace? ch rt)) plain-spaces-list))))
|
||||
(lambda (port)
|
||||
(let* ([rt (current-readtable)] [plain? (plain-readtable? rt)])
|
||||
(let loop ()
|
||||
(when plain? (skip-plain-spaces port))
|
||||
(let ([ch (peek-char port)])
|
||||
(unless (eof-object? ch)
|
||||
(when (whitespace? ch rt) (read-char port) (loop)))))))))
|
||||
|
||||
;; make n spaces, cached for n
|
||||
(define make-spaces
|
||||
(let ([t (make-hasheq)])
|
||||
(lambda (n)
|
||||
(hash-ref t n
|
||||
(lambda ()
|
||||
(let ([s (make-string n #\space)])
|
||||
(hash-set! t n s) s))))))
|
||||
|
||||
(define (bytes-width bs start)
|
||||
(let ([len (bytes-length bs)])
|
||||
(if (regexp-match? #rx"^ *$" bs start)
|
||||
(- (bytes-length bs) start)
|
||||
(let loop ([i start] [w 0])
|
||||
(if (= i len)
|
||||
w
|
||||
(loop (add1 i)
|
||||
(+ w (if (eq? 9 (bytes-ref bs i)) (- 8 (modulo w 8)) 1))))))))
|
||||
|
||||
;; A syntax object that has the "original?" property:
|
||||
(define orig-stx (read-syntax #f (open-input-string "dummy")))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; main reader function for @ constructs
|
||||
|
||||
(define (dispatcher char inp source-name line-num col-num position
|
||||
start-inside? command-readtable ch:command
|
||||
re:command re:line-item* re:line-item
|
||||
re:line-item-no-nests datum-readtable
|
||||
syntax-post-processor)
|
||||
|
||||
(define (read-error line col pos msg . xs)
|
||||
(let* ([eof? (and (eq? 'eof msg) (pair? xs))]
|
||||
[msg (apply format (if eof? xs (cons msg xs)))])
|
||||
((if eof? raise-read-error raise-read-eof-error)
|
||||
msg (or source-name (object-name inp)) line col pos (span-from pos))))
|
||||
(define (read-error* . xs)
|
||||
(apply read-error line-num col-num position xs))
|
||||
|
||||
(define (read-stx) (read-syntax/recursive source-name inp))
|
||||
(define (read-stx/rt rt) (read-syntax/recursive source-name inp #f rt))
|
||||
;; use this to avoid placeholders
|
||||
(define (read-stx*)
|
||||
;; (read-syntax/recursive source-name inp #f (current-readtable) #f)
|
||||
(read-syntax source-name inp))
|
||||
|
||||
(define (*match rx) (*regexp-match rx inp))
|
||||
(define (*match1 rx) (*regexp-match1 rx inp))
|
||||
;; (define (*skip rx) (*regexp-match-positions rx inp)) ; <- see above
|
||||
(define (*skip rx) (*regexp-match1 rx inp))
|
||||
(define (*peek rx) (*regexp-match-peek-positions rx inp))
|
||||
|
||||
(define (span-from start)
|
||||
(and start (let-values ([(line col pos) (port-next-location inp)])
|
||||
(- pos start))))
|
||||
|
||||
(define (read-delimited-list begin-re end-re end-ch)
|
||||
(let-values ([(line col pos) (port-next-location inp)])
|
||||
(and (*skip begin-re)
|
||||
(let loop ([r '()])
|
||||
(skip-whitespace inp)
|
||||
(if (*skip end-re)
|
||||
(reverse r)
|
||||
(let ([x (read-stx)])
|
||||
(if (eof-object? x)
|
||||
(read-error line col pos 'eof "expected a '~a'" end-ch)
|
||||
(loop (if (special-comment? x) r (cons x r))))))))))
|
||||
|
||||
;; identifies newlines in text
|
||||
(define (eol-syntax? x)
|
||||
(let ([p (and (syntax? x) (syntax-property x 'scribble))])
|
||||
(and (pair? p) (eq? 'newline (car p)))))
|
||||
|
||||
;; gets an accumulated (reversed) list of syntaxes and column markers, and
|
||||
;; sorts things out (remove prefix and suffix newlines, adds indentation if
|
||||
;; needed)
|
||||
(define (done-items xs)
|
||||
;; a column marker is either a non-negative integer N (saying the following
|
||||
;; code came from at column N), or a negative integer -N (saying that the
|
||||
;; following code came from column N but no need to add indentation at this
|
||||
;; point because it is at the openning of a {...}); `get-lines*' is careful
|
||||
;; not to include column markers before a newline or the end of the text,
|
||||
;; and a -N marker can only come from the beginning of the text (and it's
|
||||
;; never there if the text began with a newline)
|
||||
(if (andmap eol-syntax? xs)
|
||||
;; nothing to do
|
||||
(reverse xs)
|
||||
(let ([mincol (let loop ([xs xs] [m #f])
|
||||
(if (null? xs)
|
||||
m
|
||||
(let ([x (car xs)])
|
||||
(loop (cdr xs)
|
||||
(if (integer? x)
|
||||
(let ([x (abs x)]) (if (and m (< m x)) m x))
|
||||
m)))))])
|
||||
(let loop ([xs (if (and (not start-inside?) (eol-syntax? (car xs)))
|
||||
(cdr xs) ; trim last eol
|
||||
xs)]
|
||||
[r '()])
|
||||
(if (or (null? xs)
|
||||
(and (not start-inside?)
|
||||
;; trim first eol
|
||||
(null? (cdr xs)) (eol-syntax? (car xs))))
|
||||
r
|
||||
(loop
|
||||
(cdr xs)
|
||||
(let ([x (car xs)])
|
||||
(cond [(integer? x)
|
||||
(if (or (< x 0) (= x mincol))
|
||||
r ; no indentation marker, or zero indentation
|
||||
(let ([eol (cadr xs)]
|
||||
[spaces (make-spaces (- x mincol))])
|
||||
;; markers always follow end-of-lines
|
||||
(unless (eol-syntax? eol)
|
||||
(internal-error 'done-items))
|
||||
(cons (syntax-property
|
||||
(datum->syntax eol spaces eol)
|
||||
'scribble 'indentation)
|
||||
r)))]
|
||||
;; can have special comment values from "@||"
|
||||
[(special-comment? x) r]
|
||||
[else (cons x r)]))))))))
|
||||
|
||||
;; cons stx (new syntax) to the list of stxs, merging it if both are
|
||||
;; strings, except for newline markers
|
||||
(define (maybe-merge stx stxs)
|
||||
(let* ([2nd (and (syntax? stx) (syntax-e stx))]
|
||||
[stx0 (and (pair? stxs) (car stxs))]
|
||||
[1st (and (syntax? stx0) (syntax-e stx0))])
|
||||
(if (and (string? 1st) (not (eol-syntax? stx0))
|
||||
(string? 2nd) (not (eol-syntax? stx)))
|
||||
(cons (datum->syntax stx0
|
||||
(string-append 1st 2nd)
|
||||
(vector (syntax-source stx0)
|
||||
(syntax-line stx0)
|
||||
(syntax-column stx0)
|
||||
(syntax-position stx0)
|
||||
;; this is called right after reading stx
|
||||
(span-from (syntax-position stx0)))
|
||||
stx0)
|
||||
(cdr stxs))
|
||||
(cons stx stxs))))
|
||||
|
||||
;; helper for `get-lines*' drop a column marker if the previous item was also
|
||||
;; a newline (or the beginning)
|
||||
(define (maybe-drop-marker r)
|
||||
(if (and (pair? r) (integer? (car r))
|
||||
(or (null? (cdr r)) (eol-syntax? (cadr r))))
|
||||
(cdr r)
|
||||
r))
|
||||
|
||||
(define (get-lines* re:begin re:end re:cmd-pfx re:item end-token)
|
||||
;; re:begin, re:end, end-token can be false if start-inside? is #t;
|
||||
;; re:cmd-pfx is a regexp when we do sub-@-reads only after a prefix
|
||||
(let loop ([lvl 0]
|
||||
[r (let-values ([(l c p) (port-next-location inp)])
|
||||
;; marker for the beginning of the text
|
||||
(if c (list (- c)) '()))])
|
||||
;; this loop collects lines etc for the body, and also puts in column
|
||||
;; markers (integers) after newlines -- the result is handed off to
|
||||
;; `done-items' to finish the job
|
||||
(define-values (line col pos) (port-next-location inp))
|
||||
(define (make-stx sexpr)
|
||||
(datum->syntax #f
|
||||
(if (bytes? sexpr) (bytes->string/utf-8 sexpr) sexpr)
|
||||
(vector source-name line col pos (span-from pos))
|
||||
orig-stx))
|
||||
(cond
|
||||
[(and re:begin (*match1 re:begin))
|
||||
=> (lambda (m) (loop (add1 lvl) (maybe-merge (make-stx m) r)))]
|
||||
[(and re:end (*match1 re:end))
|
||||
=> (lambda (m)
|
||||
(if (and (zero? lvl) (not start-inside?))
|
||||
;; drop a marker if it's after a last eol item
|
||||
(done-items (maybe-drop-marker r))
|
||||
(loop (sub1 lvl) (maybe-merge (make-stx m) r))))]
|
||||
[(*match1 re:end-of-line)
|
||||
=> (lambda (m)
|
||||
(let ([n (car (regexp-match-positions #rx#"\n" m))])
|
||||
(loop lvl (list* ; no merge needed
|
||||
(bytes-width m (cdr n))
|
||||
(syntax-property
|
||||
(make-stx "\n")
|
||||
'scribble `(newline ,(bytes->string/utf-8 m)))
|
||||
(maybe-drop-marker r)))))]
|
||||
[(if re:cmd-pfx
|
||||
(and (*skip re:cmd-pfx) (*peek re:command))
|
||||
(*peek re:command))
|
||||
;; read the next value
|
||||
=> (lambda (m)
|
||||
(define x (cond [(cadr m)
|
||||
;; the command is a string escape, use
|
||||
;; `read-stx*' to not get a placeholder, so we
|
||||
;; can merge the string to others
|
||||
(read-stx*)]
|
||||
[(caddr m)
|
||||
;; it's an expression escape, get multiple
|
||||
;; expressions and put them all here
|
||||
(read-bytes (caaddr m) inp)
|
||||
(get-escape-expr #f)]
|
||||
[else (read-stx)])) ; otherwise: a plain sub-read
|
||||
(loop lvl (cond [(eof-object? x)
|
||||
;; shouldn't happen -- the sub-read would
|
||||
;; raise an error
|
||||
(internal-error 'get-lines*-sub-read)]
|
||||
;; throw away comments
|
||||
[(special-comment? x) r]
|
||||
;; escaped expressions: no merge, and add a
|
||||
;; comment to prevent merges with later stuff
|
||||
[(pair? x)
|
||||
`(,(make-special-comment #f) ,@(reverse x) ,@r)]
|
||||
[(null? x) (cons (make-special-comment #f) r)]
|
||||
[else (maybe-merge x r)])))]
|
||||
;; must be last, since it will always succeed with 1 char
|
||||
[(*peek re:item) ; don't read: regexp grabs the following text
|
||||
=> (lambda (m)
|
||||
(loop lvl
|
||||
(maybe-merge (make-stx (read-bytes (cdadr m) inp)) r)))]
|
||||
[(*peek #rx#"^$")
|
||||
(if end-token
|
||||
(read-error* 'eof "missing closing `~a'" end-token)
|
||||
(done-items r))]
|
||||
[else (internal-error 'get-lines*)])))
|
||||
|
||||
(define (get-lines)
|
||||
(cond [(*skip re:lines-begin) (get-lines* re:lines-begin re:lines-end #f
|
||||
re:line-item ch:lines-end)]
|
||||
[(*match re:lines-begin*)
|
||||
=> (lambda (m)
|
||||
(let* ([bgn (car m)]
|
||||
[end (reverse-bytes bgn)]
|
||||
[bgn* (regexp-quote bgn)]
|
||||
[end* (regexp-quote end)]
|
||||
[cmd-pfx* (regexp-quote (cadr m))])
|
||||
(get-lines* (^px bgn*) (^px end*)
|
||||
(^px cmd-pfx* "(?=" ch:command ")")
|
||||
(re:line-item* bgn* end* cmd-pfx*)
|
||||
end)))]
|
||||
[else #f]))
|
||||
|
||||
(define (get-datums)
|
||||
(parameterize ([current-readtable datum-readtable])
|
||||
(read-delimited-list re:datums-begin re:datums-end ch:datums-end)))
|
||||
|
||||
(define (get-escape-expr single?)
|
||||
;; single? means expect just one expression (or none, which is returned as
|
||||
;; a special-comment)
|
||||
(let ([get (lambda ()
|
||||
(parameterize ([current-readtable command-readtable])
|
||||
(read-delimited-list re:expr-escape re:expr-escape
|
||||
ch:expr-escape)))])
|
||||
(if single?
|
||||
(let*-values ([(line col pos) (port-next-location inp)]
|
||||
[(xs) (get)])
|
||||
(cond [(not xs) xs]
|
||||
[(or (null? xs) (not (null? (cdr xs))))
|
||||
(read-error line col pos
|
||||
"a ~a|...| form in Racket mode must have ~a"
|
||||
ch:command
|
||||
"exactly one escaped expression")]
|
||||
[else (car xs)]))
|
||||
(get))))
|
||||
|
||||
;; called only when we must see a command in the input
|
||||
(define (get-command)
|
||||
(let ([cmd (read-stx/rt command-readtable)])
|
||||
(cond [(special-comment? cmd)
|
||||
(read-error* "expecting a command expression, got a comment")]
|
||||
[(eof-object? cmd)
|
||||
(read-error* 'eof "missing command")]
|
||||
;; we have a command: adjust its location to include the dispatch
|
||||
;; character
|
||||
[else
|
||||
;; (datum->syntax #f (syntax-e cmd)
|
||||
;; (vector (syntax-source cmd)
|
||||
;; (syntax-line cmd)
|
||||
;; (cond [(syntax-column cmd) => sub1] [else #f])
|
||||
;; (cond [(syntax-position cmd) => sub1] [else #f])
|
||||
;; (cond [(syntax-span cmd) => add1] [else #f]))
|
||||
;; orig-stx)
|
||||
;; The reasoning for the above is that in `@foo' the `@' is part
|
||||
;; of the syntax of the identifier, in a similar way to including
|
||||
;; the double quotes in the position information for a string
|
||||
;; syntax or the backslash in a mzscheme \foo identifier. Another
|
||||
;; feature of this is that there needs to be some way to know what
|
||||
;; was the actual source of some syntax. However, this is
|
||||
;; problematic in two ways: (a) it can be confusing that
|
||||
;; highlighting an identifier highlights the `@' too, and more
|
||||
;; importantly, it makes `@|foo|' be treated differently than
|
||||
;; `@foo'. So we'll try to not do this adjusting.
|
||||
cmd])))
|
||||
|
||||
(define (get-rprefixes) ; return punctuation prefixes in reverse
|
||||
(let loop ([r '()])
|
||||
(let-values ([(line col pos) (port-next-location inp)])
|
||||
(cond [(*match1 #rx#"^#?(?:'|`|,@?)")
|
||||
=> (lambda (m)
|
||||
(let ([sym (cond [(assoc m '([#"'" quote]
|
||||
[#"`" quasiquote]
|
||||
[#"," unquote]
|
||||
[#",@" unquote-splicing]
|
||||
[#"#'" syntax]
|
||||
[#"#`" quasisyntax]
|
||||
[#"#," unsyntax]
|
||||
[#"#,@" unsyntax-splicing]))
|
||||
=> cadr]
|
||||
[else (internal-error 'get-rprefixes)])])
|
||||
(loop (cons (datum->syntax #f sym
|
||||
(vector source-name line col
|
||||
pos (span-from pos))
|
||||
orig-stx)
|
||||
r))))]
|
||||
[(*skip re:whitespaces)
|
||||
(read-error* "unexpected whitespace after ~a" ch:command)]
|
||||
[else r]))))
|
||||
|
||||
(cond
|
||||
[start-inside?
|
||||
(datum->syntax #f (get-lines* #f #f #f re:line-item-no-nests #f)
|
||||
(vector source-name line-num col-num position (span-from position))
|
||||
orig-stx)]
|
||||
[(*skip re:whitespaces)
|
||||
(read-error* "unexpected whitespace after ~a" ch:command)]
|
||||
[(*skip re:comment-start)
|
||||
(unless (get-lines) (*skip re:comment-line))
|
||||
(make-special-comment #f)]
|
||||
[else
|
||||
(let*-values
|
||||
([(rpfxs) (get-rprefixes)]
|
||||
[(cmd datums lines)
|
||||
(cond [(get-lines)
|
||||
;; try get-lines first -- so @|{...}| is not used as a simple
|
||||
;; expression escape, same for get-datums
|
||||
=> (lambda (lines) (values #f #f lines))]
|
||||
[(get-datums)
|
||||
=> (lambda (datums) (values #f datums (get-lines)))]
|
||||
[(get-escape-expr #t) => (lambda (expr) (values expr #f #f))]
|
||||
[else (values (get-command) (get-datums) (get-lines))])]
|
||||
[(stx) (and (or datums lines)
|
||||
(append (or datums '()) (or lines '())))]
|
||||
[(stx) (or (and cmd stx (cons cmd stx)) ; all parts
|
||||
stx ; no cmd part => just a parenthesized expression
|
||||
cmd ; no datums/lines => simple expression (no parens)
|
||||
;; impossible: either we saw []s or {}s, or we read a
|
||||
;; racket expression
|
||||
(internal-error 'dispatcher))]
|
||||
[(stx) (let ([ds (and datums (length datums))]
|
||||
[ls (and lines (length lines))])
|
||||
(syntax-property
|
||||
(if (syntax? stx)
|
||||
stx
|
||||
(datum->syntax #f stx
|
||||
(vector source-name line-num col-num position
|
||||
(span-from position))
|
||||
orig-stx))
|
||||
'scribble (list 'form ds ls)))]
|
||||
[(stx) (syntax-post-processor stx)]
|
||||
[(stx)
|
||||
;; wrap the prefixes around the result
|
||||
(let loop ([rpfxs rpfxs] [stx stx])
|
||||
(if (null? rpfxs)
|
||||
stx
|
||||
(loop (cdr rpfxs) (list (car rpfxs) stx))))])
|
||||
(datum->syntax #f stx (vector source-name line-num col-num position
|
||||
(span-from position))
|
||||
orig-stx))]))
|
||||
|
||||
(define (make-dispatcher start-inside? ch:command
|
||||
get-command-readtable get-datum-readtable
|
||||
syntax-post-processor)
|
||||
(define re:command (^px ch:command
|
||||
;; the following identifies string and expression
|
||||
;; escapes, see how it is used above
|
||||
"(?:(\")|("ch:expr-escape"))?"))
|
||||
(define (re:line-item* bgn end cmd-prefix)
|
||||
(^px "(.+?)(?:" (and bgn `(,bgn"|")) (and end `(,end"|"))
|
||||
cmd-prefix ch:command"|"str:end-of-line"|$)"))
|
||||
(define re:line-item (re:line-item* ch:lines-begin ch:lines-end #f))
|
||||
(define re:line-item-no-nests (and start-inside? (re:line-item* #f #f #f)))
|
||||
(lambda (char inp source-name line-num col-num position)
|
||||
(dispatcher char inp source-name line-num col-num position
|
||||
start-inside? (get-command-readtable) ch:command
|
||||
re:command re:line-item* re:line-item re:line-item-no-nests
|
||||
(get-datum-readtable) syntax-post-processor)))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; minor utilities for the below
|
||||
|
||||
(define default-src (gensym 'scribble-reader))
|
||||
(define (src-name src port)
|
||||
(if (eq? src default-src) (object-name port) src))
|
||||
|
||||
(define-syntax-rule (named-lambda (name . args) . body)
|
||||
(let ([name (lambda args . body)]) name))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; readtable and reader
|
||||
|
||||
(provide make-at-readtable make-at-reader)
|
||||
|
||||
(define ((make-at-readtable-or-inside-reader inside-reader?)
|
||||
readtable command-char command-readtable datum-readtable syntax-post-processor)
|
||||
(define (get-cmd-rt)
|
||||
(if (readtable? cmd-rt)
|
||||
cmd-rt
|
||||
(cmd-rt)))
|
||||
(define (get-datum-rt)
|
||||
(if (eq? datum-rt 'dynamic)
|
||||
(current-readtable)
|
||||
datum-rt))
|
||||
(define dispatcher
|
||||
(make-dispatcher #f command-char get-cmd-rt get-datum-rt
|
||||
syntax-post-processor))
|
||||
(define (make-inside-reader)
|
||||
(define dispatcher
|
||||
(make-dispatcher #t command-char get-cmd-rt get-datum-rt
|
||||
syntax-post-processor))
|
||||
;; use a name consistent with `make-at-reader'
|
||||
(named-lambda (at-read-syntax/inside [src default-src]
|
||||
[inp (current-input-port)])
|
||||
(define-values [line col pos] (port-next-location inp))
|
||||
(parameterize ([current-readtable at-rt])
|
||||
(dispatcher #f inp (src-name src inp) line col pos))))
|
||||
(define at-rt
|
||||
(make-readtable readtable command-char 'non-terminating-macro dispatcher))
|
||||
(define command-bar
|
||||
(lambda (char inp source-name line-num col-num position)
|
||||
(let ([m (*regexp-match #rx#"^([^|]*)\\|" inp)])
|
||||
(unless m
|
||||
(raise-read-error "unbalanced `|'" source-name
|
||||
line-num col-num position #f))
|
||||
(datum->syntax
|
||||
#f (string->symbol (bytes->string/utf-8 (cadr m)))
|
||||
(vector source-name line-num col-num position
|
||||
(add1 (bytes-length (car m))))
|
||||
orig-stx))))
|
||||
(define (make-cmd-rt command-readtable)
|
||||
;; similar to plain Racket (scribble, actually), but with `@' as usual and
|
||||
;; and `|' as a terminating macro characters (otherwise it behaves the
|
||||
;; same; the only difference is that `a|b|c' is three symbols)
|
||||
(make-readtable command-readtable
|
||||
command-char 'non-terminating-macro dispatcher
|
||||
#\| 'terminating-macro command-bar))
|
||||
(define cmd-rt
|
||||
(if (eq? command-readtable 'dynamic)
|
||||
(readtable-cached make-cmd-rt)
|
||||
(make-cmd-rt command-readtable)))
|
||||
(define datum-rt
|
||||
(cond [(or (not datum-readtable) (readtable? datum-readtable))
|
||||
datum-readtable]
|
||||
[(eq? #t datum-readtable) at-rt]
|
||||
[(procedure? datum-readtable) (datum-readtable at-rt)]
|
||||
[(eq? datum-readtable 'dynamic) 'dynamic]
|
||||
[else (error 'make-at-readtable
|
||||
"bad datum-readtable: ~e" datum-readtable)]))
|
||||
(if inside-reader? (make-inside-reader) at-rt))
|
||||
|
||||
(define (make-at-readtable
|
||||
#:readtable [readtable (current-readtable)]
|
||||
#:command-char [command-char ch:command]
|
||||
#:command-readtable [command-readtable readtable]
|
||||
#:datum-readtable [datum-readtable #t]
|
||||
#:syntax-post-processor [syntax-post-processor values])
|
||||
((make-at-readtable-or-inside-reader #f)
|
||||
readtable command-char command-readtable datum-readtable syntax-post-processor))
|
||||
|
||||
(define (make-at-reader
|
||||
#:readtable [readtable (current-readtable)]
|
||||
#:command-char [command-char ch:command]
|
||||
#:datum-readtable [datum-readtable #t]
|
||||
#:command-readtable [command-readtable readtable]
|
||||
#:syntax-post-processor [syntax-post-processor values]
|
||||
#:syntax? [syntax-reader? #t]
|
||||
#:inside? [inside-reader? #f])
|
||||
(let ([r ((make-at-readtable-or-inside-reader inside-reader?)
|
||||
readtable command-char command-readtable datum-readtable syntax-post-processor)])
|
||||
;; the result can be a readtable or a syntax reader, depending on inside?,
|
||||
;; convert it now to the appropriate reader
|
||||
(if inside-reader?
|
||||
;; if it's a function, then it already is a syntax reader, convert it to
|
||||
;; a plain reader if needed (note: this only happens when r is a reader)
|
||||
(if syntax-reader?
|
||||
r
|
||||
(named-lambda (at-read/inside [in (current-input-port)])
|
||||
;; can't be eof, since it returns a list of expressions (as a syntax)
|
||||
(syntax->datum (r (object-name in) in))))
|
||||
;; if it's a readtable, then just wrap the standard functions
|
||||
(if syntax-reader?
|
||||
(named-lambda (at-read-syntax [src default-src]
|
||||
[inp (current-input-port)])
|
||||
(parameterize ([current-readtable r])
|
||||
(read-syntax src inp)))
|
||||
(named-lambda (at-read [inp (current-input-port)])
|
||||
(parameterize ([current-readtable r])
|
||||
(let ([r (read-syntax (object-name inp) inp)])
|
||||
;; it might be eof
|
||||
(if (syntax? r) (syntax->datum r) r))))))))
|
||||
|
||||
(provide use-at-readtable)
|
||||
(define use-at-readtable
|
||||
(make-keyword-procedure
|
||||
(lambda (kws kw-args . rest)
|
||||
(port-count-lines! (current-input-port))
|
||||
(current-readtable
|
||||
(keyword-apply make-at-readtable kws kw-args rest)))))
|
||||
|
||||
;; utilities for below
|
||||
(define make-default-at-readtable
|
||||
(readtable-cached (lambda (rt) (make-at-readtable #:readtable rt
|
||||
#:command-readtable 'dynamic
|
||||
#:datum-readtable 'dynamic))))
|
||||
(define make-default-at-reader/inside
|
||||
(readtable-cached
|
||||
(lambda (rt) (make-at-reader #:inside? #t #:readtable rt
|
||||
#:command-readtable 'dynamic
|
||||
#:datum-readtable 'dynamic))))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; readers
|
||||
|
||||
(provide (rename-out [*read read] [*read-syntax read-syntax]))
|
||||
(define (*read [inp (current-input-port)])
|
||||
(parameterize ([current-readtable (make-default-at-readtable)])
|
||||
(read inp)))
|
||||
(define (*read-syntax [src default-src] [inp (current-input-port)])
|
||||
(parameterize ([current-readtable (make-default-at-readtable)])
|
||||
(read-syntax (src-name src inp) inp)))
|
||||
|
||||
(provide read-inside read-syntax-inside)
|
||||
(define (read-inside [inp (current-input-port)])
|
||||
(syntax->datum ((make-default-at-reader/inside) default-src inp)))
|
||||
(define (read-syntax-inside [src default-src] [inp (current-input-port)]
|
||||
#:command-char [command-char ch:command])
|
||||
(((readtable-cached
|
||||
(lambda (rt) (make-at-reader #:inside? #t #:command-char command-char #:readtable rt))))
|
||||
src inp))
|
||||
@ -0,0 +1,85 @@
|
||||
#lang racket/base
|
||||
|
||||
(module runtime-config racket/base
|
||||
(provide configure)
|
||||
|
||||
(require (only-in "mode-helper.rkt" make-at-readtable))
|
||||
|
||||
(define (configure data)
|
||||
(define old-read (current-read-interaction))
|
||||
(define (new-read src in)
|
||||
(parameterize ([current-readtable (make-at-readtable #:readtable (current-readtable))])
|
||||
(old-read src in)))
|
||||
(current-read-interaction new-read)))
|
||||
|
||||
(module language-info racket/base
|
||||
(provide get-language-info)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(define (get-language-info data)
|
||||
(define other-get-info
|
||||
(match data
|
||||
[(vector mod sym data2)
|
||||
((dynamic-require mod sym) data2)]
|
||||
[_ (λ(key default) default)]))
|
||||
(λ(key default)
|
||||
(case key
|
||||
[(configure-runtime)
|
||||
(define config-vec '#[(submod pollen/mode runtime-config) configure #f])
|
||||
(define other-config (other-get-info key default))
|
||||
(cond [(list? other-config) (cons config-vec other-config)]
|
||||
[else (list config-vec)])]
|
||||
[else (other-get-info key default)]))))
|
||||
|
||||
(module reader racket/base
|
||||
(require syntax/module-reader pollen/world
|
||||
(only-in "mode-helper.rkt" make-at-readtable))
|
||||
|
||||
(provide (rename-out [at-read read]
|
||||
[at-read-syntax read-syntax]
|
||||
[at-get-info get-info]))
|
||||
|
||||
(define (wrap-reader p)
|
||||
(λ args
|
||||
(parameterize ([current-readtable (make-at-readtable #:datum-readtable 'dynamic
|
||||
#:command-readtable 'dynamic
|
||||
#:command-char (world:current-command-char))])
|
||||
(apply p args))))
|
||||
|
||||
(define-values (at-read at-read-syntax at-get-info)
|
||||
(make-meta-reader
|
||||
'pollen/mode
|
||||
"language path"
|
||||
(λ(bstr)
|
||||
(let* ([str (bytes->string/latin-1 bstr)]
|
||||
[sym (string->symbol str)])
|
||||
(and (module-path? sym)
|
||||
(vector
|
||||
;; try submod first:
|
||||
`(submod ,sym reader)
|
||||
;; fall back to /lang/reader:
|
||||
(string->symbol (string-append str "/lang/reader"))))))
|
||||
wrap-reader
|
||||
(λ(orig-read-syntax)
|
||||
(define read-syntax (wrap-reader orig-read-syntax))
|
||||
(λ args
|
||||
(define stx (apply read-syntax args))
|
||||
(define old-prop (syntax-property stx 'module-language))
|
||||
(define new-prop `#((submod pollen/mode language-info) get-language-info ,old-prop))
|
||||
(syntax-property stx 'module-language new-prop)))
|
||||
(λ(proc)
|
||||
(λ(key defval)
|
||||
(define (fallback) (if proc (proc key defval) defval))
|
||||
(define (try-dynamic-require mod export)
|
||||
(or (with-handlers ([exn:fail? (λ(x) #f)])
|
||||
(dynamic-require mod export))
|
||||
(fallback)))
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(try-dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
|
||||
[(definitions-text-surrogate)
|
||||
'scribble/private/indentation]
|
||||
[(drracket:indentation)
|
||||
(dynamic-require 'scribble/private/indentation 'determine-spaces)]
|
||||
[else (fallback)]))))))
|
||||
@ -0,0 +1,7 @@
|
||||
#lang pollen/mode racket/base
|
||||
(require rackunit racket/string)
|
||||
|
||||
(define (proc)
|
||||
(apply string-join (string-split ◊string-append{foo bar zam}) ◊'{X}))
|
||||
|
||||
(check-equal? (proc) "fooXbarXzam")
|
||||
Loading…
Reference in New Issue