Use arg-str instead of arg-char and update docs
This commit is contained in:
AlexKnauth
parent
22666f19a5
commit
206c937bf7
8
.gitignore
vendored
8
.gitignore
vendored
|
|
@ -1,2 +1,10 @@
|
|||
|
||||
*.scrbl~
|
||||
|
||||
*.rkt~
|
||||
|
||||
*.html
|
||||
|
||||
*.css
|
||||
|
||||
*.js
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require (for-label (except-in racket/base
|
||||
@(require scribble/eval
|
||||
(for-label (except-in racket/base
|
||||
read read-syntax)
|
||||
(except-in afl/reader
|
||||
read read-syntax)))
|
||||
|
|
@ -29,15 +30,57 @@ produces @racket['(2 3 4)]
|
|||
|
||||
@defmodule[afl/reader]
|
||||
|
||||
@deftogether[(@defproc[(afl-read [in input-port? (current-input-port)]) any]{}
|
||||
@defproc[(afl-read-syntax [source-name any/c (object-name in)] [in input-port? (current-input-port)]) (or/c syntax? eof-object?)]{})]{
|
||||
@deftogether[(@defproc[(afl-read [in input-port? (current-input-port)]
|
||||
[#:arg-str arg-str string? (current-arg-string)]) any]{}
|
||||
@defproc[(afl-read-syntax [source-name any/c (object-name in)]
|
||||
[in input-port? (current-input-port)]
|
||||
[#:arg-str arg-str string? (current-arg-string)])
|
||||
(or/c syntax? eof-object?)]{})]{
|
||||
These procedures implement the @racketmodname[afl] reader. They do so by
|
||||
constructing a readtable based on the current one, and using that
|
||||
for reading.
|
||||
|
||||
@racketmodname[afl/reader] also exports these functions under the names @racket[read] and @racket[read-syntax].
|
||||
The @racket[arg-str] argument lets you specify something else to use as a placeholder instead of
|
||||
@racket[%].
|
||||
|
||||
@examples[
|
||||
(require afl/reader)
|
||||
(afl-read (open-input-string "#λ(+ % %2)"))
|
||||
(afl-read (open-input-string "#λ(+ _ _2)") #:arg-str "_")
|
||||
]
|
||||
|
||||
@racketmodname[afl/reader] also exports these functions under the names @racket[read] and
|
||||
@racket[read-syntax].
|
||||
}
|
||||
|
||||
@defproc[(make-afl-readtable [orig-readtable readtable? (current-readtable)]) readtable?]{
|
||||
@defproc[(make-afl-readtable [orig-readtable readtable? (current-readtable)]
|
||||
[#:arg-str arg-str string? (current-arg-string)]) readtable?]{
|
||||
makes an @racketmodname[afl] readtable based on @racket[orig-readtable].
|
||||
|
||||
The @racket[arg-str] argument lets you specify something else to use as a placeholder instead of
|
||||
@racket[%], just like for @racket[afl-read].
|
||||
}
|
||||
|
||||
@defproc[(use-afl-readtable [orig-readtable readtable? (current-readtable)]
|
||||
[#:arg-str arg-str string? (current-arg-string)]) void?]{
|
||||
passes arguments to @racket[make-afl-readtable] and sets the @racket[current-readtable] parameter to
|
||||
the resulting readtable.
|
||||
It also enables line counting for the @racket[current-input-port] via @racket[port-count-lines!].
|
||||
|
||||
This is mostly useful for the REPL.
|
||||
|
||||
@verbatim{
|
||||
Examples:
|
||||
|
||||
> @racket[(require afl/reader)]
|
||||
> @racket[(use-afl-readtable)]
|
||||
> @racket[(map @#,afl[(+ % %2)] '(1 2 3) '(1 2 3))]
|
||||
@racketresult['(2 4 6)]
|
||||
> @racket[(use-afl-readtable #:arg-str "_")]
|
||||
> @racket[(map @#,afl[(+ _ _2)] '(1 2 3) '(1 2 3))]
|
||||
@racketresult['(2 4 6)]
|
||||
}}
|
||||
|
||||
@defparam[current-arg-string arg-str string?]{
|
||||
a parameter that controls default values of the @racket[arg-str] arguments to @racket[afl-read] etc.
|
||||
}
|
||||
178
afl/reader.rkt
178
afl/reader.rkt
|
|
@ -4,6 +4,8 @@
|
|||
afl-read
|
||||
afl-read-syntax
|
||||
wrap-reader
|
||||
use-afl-readtable
|
||||
current-arg-string
|
||||
(rename-out
|
||||
[afl-read read]
|
||||
[afl-read-syntax read-syntax])
|
||||
|
|
@ -16,14 +18,20 @@
|
|||
(for-template racket/base)
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define (afl-read [in (current-input-port)])
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
(define (afl-read [in (current-input-port)] #:arg-str [arg-str (current-arg-string)])
|
||||
(define orig-readtable (current-readtable))
|
||||
(parameterize ([current-readtable (make-afl-readtable orig-readtable)])
|
||||
(parameterize ([current-arg-string arg-str]
|
||||
[current-readtable (make-afl-readtable orig-readtable #:arg-str arg-str)])
|
||||
(read in)))
|
||||
|
||||
(define (afl-read-syntax [src (object-name (current-input-port))] [in (current-input-port)])
|
||||
(define (afl-read-syntax [src (object-name (current-input-port))] [in (current-input-port)]
|
||||
#:arg-str [arg-str (current-arg-string)])
|
||||
(define orig-readtable (current-readtable))
|
||||
(parameterize ([current-readtable (make-afl-readtable orig-readtable)])
|
||||
(parameterize ([current-arg-string arg-str]
|
||||
[current-readtable (make-afl-readtable orig-readtable #:arg-str arg-str)])
|
||||
(read-syntax src in)))
|
||||
|
||||
(define (wrap-reader p)
|
||||
|
|
@ -32,51 +40,68 @@
|
|||
(parameterize ([current-readtable (make-afl-readtable orig-readtable)])
|
||||
(apply p args))))
|
||||
|
||||
(define (make-afl-readtable [orig-rt (current-readtable)] #:arg-char [arg-char #\%])
|
||||
(define reader-proc (make-reader-proc orig-rt #:arg-char arg-char))
|
||||
(define (make-afl-readtable [orig-rt (current-readtable)] #:arg-str [arg-str (current-arg-string)])
|
||||
(define reader-proc (make-reader-proc orig-rt #:arg-str arg-str))
|
||||
(let* ([rt orig-rt]
|
||||
[rt (make-readtable rt #\λ 'dispatch-macro reader-proc)]
|
||||
[rt (make-readtable rt #\f 'dispatch-macro reader-proc)]
|
||||
[rt (make-readtable rt #\l 'dispatch-macro reader-proc)])
|
||||
rt))
|
||||
|
||||
(define (use-afl-readtable [orig-rt (current-readtable)] #:arg-str [arg-str (current-arg-string)])
|
||||
(port-count-lines! (current-input-port))
|
||||
(current-readtable (make-afl-readtable orig-rt #:arg-str arg-str)))
|
||||
|
||||
(define current-arg-string (make-parameter "%"))
|
||||
|
||||
(define ((make-reader-proc [orig-rt (current-readtable)] #:arg-char [arg-char #\%])
|
||||
char in source line column pos)
|
||||
(define (unget-normal-read-syntax str src in)
|
||||
(define rt (current-readtable))
|
||||
(parameterize ([current-readtable orig-rt])
|
||||
(read-syntax/recursive src (input-port-append #f (open-input-string str) in) #f rt)))
|
||||
(define (peek/read? str in)
|
||||
(and (equal? str (peek-string (string-length str) 0 in))
|
||||
(read-string (string-length str) in)))
|
||||
(cond [(char=? char #\l)
|
||||
(cond [(peek/read? "ambda" in) (parse (read-syntax source in) #:arg-char arg-char)]
|
||||
[else (unget-normal-read-syntax "#l" source in)])]
|
||||
[(char=? char #\f)
|
||||
(cond [(peek/read? "n" in) (parse (read-syntax source in) #:arg-char arg-char)]
|
||||
[(peek/read? "unction" in) (parse (read-syntax source in) #:arg-char arg-char)]
|
||||
[else (unget-normal-read-syntax "#f" source in)])]
|
||||
[(char=? char #\λ) (parse (read-syntax source in) #:arg-char arg-char)]
|
||||
;[else (unget-normal-read-syntax (string #\# char) source in)]
|
||||
[else (parse (read-syntax source in) #:arg-char arg-char)] ;single letter e.g. #λ
|
||||
))
|
||||
|
||||
(define (parse stx #:arg-char [arg-char #\%])
|
||||
(define arg-str (string arg-char))
|
||||
(define (string->id stx . strs)
|
||||
(datum->syntax stx (string->symbol (apply string-append strs)) stx))
|
||||
(with-syntax ([args (parse-args stx #:arg-char arg-char)]
|
||||
[% (string->id #'args arg-str)]
|
||||
[%1 (string->id #'args arg-str "1")]
|
||||
[body stx])
|
||||
#'(lambda args
|
||||
(define-syntax % (make-rename-transformer #'%1))
|
||||
body)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (afl-read (open-input-string "#λ(+ % %2)"))
|
||||
'(lambda (%1 %2)
|
||||
(define-syntax % (make-rename-transformer #'%1))
|
||||
(+ % %2)))
|
||||
(check-equal? (afl-read (open-input-string "#λ(+ _ _2)") #:arg-str "_")
|
||||
'(lambda (_1 _2)
|
||||
(define-syntax _ (make-rename-transformer #'_1))
|
||||
(+ _ _2)))
|
||||
)
|
||||
|
||||
|
||||
(define ((make-reader-proc [orig-rt (current-readtable)] #:arg-str [arg-str (current-arg-string)])
|
||||
char in source line column pos)
|
||||
(parameterize ([current-arg-string arg-str])
|
||||
(define (unget-normal-read-syntax str src in)
|
||||
(define rt (current-readtable))
|
||||
(parameterize ([current-readtable orig-rt])
|
||||
(read-syntax/recursive src (input-port-append #f (open-input-string str) in) #f rt)))
|
||||
(define (peek/read? str in)
|
||||
(and (equal? str (peek-string (string-length str) 0 in))
|
||||
(read-string (string-length str) in)))
|
||||
(cond [(char=? char #\l)
|
||||
(cond [(peek/read? "ambda" in) (parse (read-syntax source in))]
|
||||
[else (unget-normal-read-syntax "#l" source in)])]
|
||||
[(char=? char #\f)
|
||||
(cond [(peek/read? "n" in) (parse (read-syntax source in))]
|
||||
[(peek/read? "unction" in) (parse (read-syntax source in))]
|
||||
[else (unget-normal-read-syntax "#f" source in)])]
|
||||
[(char=? char #\λ) (parse (read-syntax source in))]
|
||||
;[else (unget-normal-read-syntax (string #\# char) source in)]
|
||||
[else (parse (read-syntax source in))] ;single letter e.g. #λ
|
||||
)))
|
||||
|
||||
(define (parse stx #:arg-str [arg-str (current-arg-string)])
|
||||
(parameterize ([current-arg-string arg-str])
|
||||
(define (string->id stx . strs)
|
||||
(datum->syntax stx (string->symbol (apply string-append strs)) stx))
|
||||
(with-syntax ([args (parse-args stx #:arg-str arg-str)]
|
||||
[% (string->id #'args arg-str)]
|
||||
[%1 (string->id #'args arg-str "1")]
|
||||
[body stx])
|
||||
#'(lambda args
|
||||
(define-syntax % (make-rename-transformer #'%1))
|
||||
body))))
|
||||
|
||||
(module+ test
|
||||
;; These test `parse`. See test.rkt for tests of readtable use per se.
|
||||
(define chk (compose1 syntax->datum parse))
|
||||
(check-equal? (chk #'(+))
|
||||
|
|
@ -94,55 +119,68 @@
|
|||
(check-equal? (chk #'(apply list* % %&))
|
||||
'(lambda (%1 . %&)
|
||||
(define-syntax % (make-rename-transformer #'%1))
|
||||
(apply list* % %&))))
|
||||
(apply list* % %&)))
|
||||
(check-equal? (parameterize ([current-arg-string "_"])
|
||||
(chk #'(apply list* _ _&)))
|
||||
'(lambda (_1 . _&)
|
||||
(define-syntax _ (make-rename-transformer #'_1))
|
||||
(apply list* _ _&))))
|
||||
|
||||
;; parse-args : Stx -> KW-Formals-Stx
|
||||
(define (parse-args stx #:arg-char arg-char)
|
||||
(define (parse-args stx #:arg-str [arg-str (current-arg-string)])
|
||||
;; Filter the stxs to those that start with %,
|
||||
;; find the maximum, find whether there are any
|
||||
;; keyword arguments or a rest argument, and
|
||||
;; produce kw-formals based on that.
|
||||
(define arg-str (string arg-char))
|
||||
(define-values (max-num rest? kws)
|
||||
(find-arg-info stx #:arg-char arg-char))
|
||||
(define datum-kw-formals
|
||||
(append (for/list ([n (in-range 1 (add1 max-num))])
|
||||
(string->symbol (string-append arg-str (number->string n))))
|
||||
(append*
|
||||
(for/list ([kw (in-list kws)])
|
||||
(list kw (string->symbol (string-append arg-str "#:" (keyword->string kw))))))
|
||||
(cond [rest? (string->symbol (string-append arg-str "&"))]
|
||||
[else '()])))
|
||||
(datum->syntax stx datum-kw-formals stx))
|
||||
(parameterize ([current-arg-string arg-str])
|
||||
(define-values (max-num rest? kws)
|
||||
(find-arg-info stx))
|
||||
(define datum-kw-formals
|
||||
(append (for/list ([n (in-range 1 (add1 max-num))])
|
||||
(string->symbol (string-append arg-str (number->string n))))
|
||||
(append*
|
||||
(for/list ([kw (in-list kws)])
|
||||
(list kw (string->symbol (string-append arg-str "#:" (keyword->string kw))))))
|
||||
(cond [rest? (string->symbol (string-append arg-str "&"))]
|
||||
[else '()])))
|
||||
(datum->syntax stx datum-kw-formals stx)))
|
||||
|
||||
;; find-arg-info : Any -> (Values Natural Boolean (Listof Keyword))
|
||||
(define (find-arg-info v #:arg-char arg-char)
|
||||
(define (find-arg-info v)
|
||||
(match (maybe-syntax-e v)
|
||||
[(? symbol? sym) (find-arg-info/sym sym #:arg-char arg-char)]
|
||||
[(? pair? pair) (find-arg-info/pair pair #:arg-char arg-char)]
|
||||
[(? symbol? sym) (find-arg-info/sym sym)]
|
||||
[(? pair? pair) (find-arg-info/pair pair)]
|
||||
[_ (return)]))
|
||||
|
||||
;; find-arg-info/sym : Symbol -> (Values Natural Boolean (Listof Keyword))
|
||||
(define (find-arg-info/sym sym #:arg-char arg-char)
|
||||
(define (arg-char? char)
|
||||
(char=? char arg-char))
|
||||
(match (~> sym symbol->string string->list)
|
||||
[(list) (return)]
|
||||
[(list (? arg-char?)) (return #:max-num 1)]
|
||||
[(list (? arg-char?) #\&) (return #:rest? #t)]
|
||||
[(list* (? arg-char?) #\# #\: cs)
|
||||
(return #:kws (~> cs list->string string->keyword list))]
|
||||
[(list (? arg-char?) (? char-numeric? cs) ...)
|
||||
(return #:max-num (~> cs list->string string->number))]
|
||||
(define (find-arg-info/sym sym)
|
||||
(define arg-str (current-arg-string))
|
||||
(define (arg-str? str)
|
||||
(string=? str arg-str))
|
||||
(define (arg-cs? cs)
|
||||
(arg-str? (~> cs list->string)))
|
||||
(define str (~> sym symbol->string))
|
||||
(match (~> str string->list)
|
||||
[(list) (return)]
|
||||
[_ #:when (arg-str? str) (return #:max-num 1)]
|
||||
[(list arg-cs ... #\&)
|
||||
#:when (arg-cs? arg-cs)
|
||||
(return #:rest? #t)]
|
||||
[(list* arg-cs ... #\# #\: kw-cs)
|
||||
#:when (arg-cs? arg-cs)
|
||||
(return #:kws (~> kw-cs list->string string->keyword list))]
|
||||
[(list arg-cs ... (? char-numeric? n-cs) ...)
|
||||
#:when (arg-cs? arg-cs)
|
||||
(return #:max-num (~> n-cs list->string string->number))]
|
||||
[_ (return)]))
|
||||
|
||||
;; find-arg-info/pair :
|
||||
;; (Cons Symbol Symbol) -> (Values Natural Boolean (Listof Keyword))
|
||||
(define (find-arg-info/pair pair #:arg-char arg-char)
|
||||
(define (find-arg-info/pair pair)
|
||||
(define-values (car.max-num car.rest? car.kws)
|
||||
(find-arg-info (car pair) #:arg-char arg-char))
|
||||
(find-arg-info (car pair)))
|
||||
(define-values (cdr.max-num cdr.rest? cdr.kws)
|
||||
(find-arg-info (cdr pair) #:arg-char arg-char))
|
||||
(find-arg-info (cdr pair)))
|
||||
(return #:max-num (max car.max-num cdr.max-num)
|
||||
#:rest? (or car.rest? cdr.rest?)
|
||||
#:kws (remove-duplicates (append car.kws cdr.kws))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user