236 lines
9.8 KiB
Racket
236 lines
9.8 KiB
Racket
#lang racket/base
|
||
|
||
(require racket/contract/base)
|
||
(provide
|
||
(contract-out
|
||
[make-string-delim-readtable
|
||
(->* (char? char?) (#:base-readtable readtable?) readtable?)]
|
||
[make-string-delim-readtable/wrap
|
||
(->* (char? char? symbol?) (#:base-readtable readtable?) readtable?)]
|
||
[make-list-delim-readtable
|
||
(->* (char? char?) (#:base-readtable readtable?) readtable?)]
|
||
[make-list-delim-readtable/wrap
|
||
(->* (char? char? symbol?) (#:base-readtable readtable?) readtable?)]
|
||
[udelimify (->* ((or/c readtable? false/c)) readtable?)]
|
||
[stx-string->port (->* (syntax?) input-port?)]
|
||
[scribble-strings->string (->* (syntax?) syntax?)]
|
||
))
|
||
|
||
(require syntax/readerr)
|
||
|
||
(define (make-raise-balance-error l-paren r-paren)
|
||
(define raise-balance-error
|
||
(case-lambda
|
||
[(ch port) (raise-balance-error ch port #f #f #f #f)]
|
||
[(ch port src line col pos)
|
||
(raise-read-error (format "unexpected closing delimiter ~a~n" r-paren)
|
||
src line col pos #f)]))
|
||
raise-balance-error)
|
||
|
||
(define (make-string-reader l-paren r-paren)
|
||
;; balance parens, and return the contents as a bare string with no escapes
|
||
(define string-reader
|
||
(case-lambda
|
||
[(ch port) (syntax->datum (string-reader ch port #f #f #f #f))]
|
||
[(ch port src line col pos)
|
||
(define-values (n-line n-col n-pos) (port-next-location port))
|
||
(define (loop ch cur-balance-level ch-so-far)
|
||
(cond [(equal? eof ch)
|
||
(raise-read-error
|
||
(format "unexpected eof, expected ~a more closing delimiter ~a~n"
|
||
cur-balance-level r-paren)
|
||
src line col pos #f)]
|
||
[(equal? ch l-paren) (loop (read-char port)
|
||
(add1 cur-balance-level)
|
||
(cons ch ch-so-far))]
|
||
[(not (equal? ch r-paren)) (loop (read-char port)
|
||
cur-balance-level
|
||
(cons ch ch-so-far))]
|
||
[(> cur-balance-level 1) (loop (read-char port)
|
||
(sub1 cur-balance-level)
|
||
(cons ch ch-so-far))]
|
||
;; this shouldn't be possible... but I'll leave it here anyway.
|
||
[(< cur-balance-level 1)
|
||
((make-raise-balance-error l-paren r-paren)
|
||
src line col pos)]
|
||
[else
|
||
(let* ([final-chs (cdr (reverse ch-so-far))]
|
||
[span (length final-chs)])
|
||
(datum->syntax
|
||
#f (apply string final-chs)
|
||
(list src n-line n-col n-pos span)))]))
|
||
(loop ch 0 '())]))
|
||
string-reader)
|
||
|
||
(define (make-list-reader l-paren r-paren)
|
||
(define paren-reader
|
||
(case-lambda
|
||
[(ch port) (syntax->datum (paren-reader ch port #f #f #f #f))]
|
||
[(ch port src line col pos)
|
||
(define (loop stxs-rev)
|
||
(let ([next-ch (read-char port)])
|
||
(cond
|
||
#| TODO - what if one of these whitespace characters is bound
|
||
to something non-default in the readtable?? For now, just ignore
|
||
them. |#
|
||
[(member next-ch '(#\space #\tab #\newline #\vtab #\return))
|
||
(loop stxs-rev)]
|
||
[(equal? next-ch r-paren)
|
||
(datum->syntax #f (reverse stxs-rev))]
|
||
[else (let ([one-stx (read-syntax/recursive src port next-ch)])
|
||
(loop (cons one-stx stxs-rev)))])))
|
||
(loop '())]))
|
||
paren-reader)
|
||
|
||
(define (make-delim-reader/wrap unwrapped-reader-maker list? delim-l delim-r wrapper-sym)
|
||
(define reader (unwrapped-reader-maker delim-l delim-r))
|
||
(define delim-reader-wrapped
|
||
(case-lambda
|
||
[(ch port) (syntax->datum (delim-reader-wrapped ch port #f #f #f #f))]
|
||
[(ch port src line col pos)
|
||
(with-syntax ([str-stx (reader ch port src line col pos)])
|
||
(if list?
|
||
#`(#,wrapper-sym . str-stx)
|
||
#`(#,wrapper-sym str-stx)))]))
|
||
delim-reader-wrapped)
|
||
|
||
(define (make-string-reader/wrap l r wrapper-sym)
|
||
(make-delim-reader/wrap make-string-reader #f l r wrapper-sym))
|
||
(define (make-list-reader/wrap l r wrapper-sym)
|
||
(make-delim-reader/wrap make-list-reader #t l r wrapper-sym))
|
||
|
||
(define (make-make-delim-readtable make-reader)
|
||
(λ (l-paren r-paren #:base-readtable [base-readtable #f])
|
||
(make-readtable
|
||
base-readtable
|
||
l-paren 'terminating-macro (make-reader l-paren r-paren)
|
||
r-paren 'terminating-macro (make-raise-balance-error l-paren r-paren))))
|
||
|
||
(define (make-make-delim-readtable/wrap make-reader/wrap)
|
||
(λ (l-paren r-paren wrapper-symbol #:base-readtable [base-readtable #f])
|
||
(make-readtable
|
||
base-readtable
|
||
l-paren 'terminating-macro (make-reader/wrap l-paren r-paren wrapper-symbol)
|
||
r-paren 'terminating-macro (make-raise-balance-error l-paren r-paren))))
|
||
|
||
(define make-string-delim-readtable
|
||
(make-make-delim-readtable make-string-reader))
|
||
(define make-list-delim-readtable
|
||
(make-make-delim-readtable make-list-reader))
|
||
(define make-string-delim-readtable/wrap
|
||
(make-make-delim-readtable/wrap make-string-reader/wrap))
|
||
(define make-list-delim-readtable/wrap
|
||
(make-make-delim-readtable/wrap make-list-reader/wrap))
|
||
|
||
(define (udelimify table)
|
||
(make-list-delim-readtable/wrap
|
||
#\🌜 #\🌛 '#%moon-faces
|
||
#:base-readtable
|
||
(make-list-delim-readtable/wrap
|
||
#\⦕ #\⦖ '#%double-inequality-brackets
|
||
#:base-readtable
|
||
(make-list-delim-readtable/wrap
|
||
#\⦓ #\⦔ '#%inequality-brackets
|
||
#:base-readtable
|
||
(make-list-delim-readtable/wrap
|
||
#\﴾ #\﴿ '#%ornate-parens
|
||
#:base-readtable
|
||
(make-list-delim-readtable/wrap
|
||
#\⟅ #\⟆ '#%s-shaped-bag-delim
|
||
#:base-readtable
|
||
(make-string-delim-readtable/wrap
|
||
#\｢ #\｣ '#%cjk-corner-quotes
|
||
#:base-readtable
|
||
(make-string-delim-readtable
|
||
#\« #\»
|
||
#:base-readtable table))))))))
|
||
|
||
(define (stx-string->port stx)
|
||
(let ([str (syntax->datum stx)]
|
||
[line (syntax-line stx)]
|
||
[col (syntax-column stx)]
|
||
[pos (syntax-position stx)]
|
||
[src (syntax-source stx)])
|
||
(if (not (string? str))
|
||
(error 'stx-string->port "syntax is not a string: ~a~n" stx)
|
||
(let ([p (open-input-string str src)])
|
||
(port-count-lines! p)
|
||
(set-port-next-location! p line col pos)
|
||
p))))
|
||
|
||
(define (reconstitute-scribble-strings stx)
|
||
;; Based on `verb` macro in reader-internals docs.
|
||
;; If there is a newline after the opening brace, it doesn't
|
||
;; seem to show up, still. Oh well.
|
||
(syntax-case stx ()
|
||
[(item ...)
|
||
(datum->syntax
|
||
stx
|
||
(let loop ([items (syntax->list #'(item ...))])
|
||
(if (null? items)
|
||
'()
|
||
(let* ([fst (car items)]
|
||
[prop (syntax-property fst 'scribble)]
|
||
[rst (loop (cdr items))])
|
||
(cond [(not prop) (cons fst rst)]
|
||
[(eq? prop 'indentation) rst]
|
||
[(not (and (pair? prop)
|
||
(eq? (car prop) 'newline)))
|
||
(cons fst rst)]
|
||
[else (cons (datum->syntax
|
||
fst (cadr prop) fst)
|
||
rst)])))))]))
|
||
|
||
(define (scribble-strings->string stx)
|
||
(syntax-case stx ()
|
||
[(arg ...)
|
||
(let* ([error-if-not-str (λ (s) (or (string? (syntax->datum s))
|
||
(raise-syntax-error 'scribble-strings->string
|
||
"expected string"
|
||
s)))]
|
||
[all-strs? (map error-if-not-str (syntax->list stx))]
|
||
[one-str (apply string-append
|
||
(map syntax->datum
|
||
(syntax->list
|
||
(reconstitute-scribble-strings #'(arg ...)))))]
|
||
[s (car (syntax->list #'(arg ...)))]
|
||
[loclist (list (syntax-source s) (syntax-line s) (syntax-column s)
|
||
(syntax-position s) (string-length one-str))])
|
||
(datum->syntax s one-str loclist))]))
|
||
|
||
(module+ test
|
||
(require rackunit)
|
||
|
||
(define mytable (make-string-delim-readtable #\{ #\}))
|
||
(define guillemet-table
|
||
(make-string-delim-readtable/wrap #\« #\» '#%guillemets))
|
||
(define ceil-table (make-list-delim-readtable #\⌈ #\⌉))
|
||
(define ceil-table/wrap (make-list-delim-readtable/wrap #\⌈ #\⌉ '#%ceil))
|
||
|
||
(parameterize ([current-readtable mytable])
|
||
(let ([port (open-input-string " \"in a string {here\" {hello @{testing 123}foo} }goodbye")])
|
||
(check-equal? (syntax->datum (read-syntax "foo" port))
|
||
"in a string {here")
|
||
(check-equal? (syntax->datum (read-syntax "foo" port))
|
||
"hello @{testing 123}foo")
|
||
(check-exn exn? (λ () (read-syntax "foo" port)))))
|
||
|
||
(parameterize ([current-readtable guillemet-table])
|
||
(let ([port (open-input-string " \"in a string «here\" «hello @«testing 123»foo» »goodbye")])
|
||
(check-equal? (syntax->datum (read-syntax "foo" port))
|
||
"in a string «here")
|
||
(check-equal? (syntax->datum (read-syntax "foo" port))
|
||
'(#%guillemets "hello @«testing 123»foo"))
|
||
(check-exn exn? (λ () (read-syntax "foo" port)))))
|
||
|
||
(parameterize ([current-readtable ceil-table])
|
||
(let ([port (open-input-string "(testing ⌈foo bar ⌈⌉ aoeu⌉ hello) foo")])
|
||
(check-equal? (syntax->datum (read-syntax "foo" port))
|
||
'(testing (foo bar () aoeu) hello))))
|
||
|
||
(parameterize ([current-readtable ceil-table/wrap])
|
||
(let ([port (open-input-string "(testing ⌈foo bar ⌈⌉ aoeu⌉ hello) foo")])
|
||
(check-equal? (syntax->datum (read-syntax "foo" port))
|
||
'(testing (#%ceil foo bar (#%ceil) aoeu) hello))))
|
||
)
|