commit 206c937bf7d8ab5c87962c396a5aa6c2fab7011a
parent 22666f19a55e3ac3c7af0234a8fc0b04672b3dcf
Author: AlexKnauth <alexander@knauth.org>
Date: Wed, 16 Jul 2014 16:49:13 -0400
Use arg-str instead of arg-char and update docs
Diffstat:
3 files changed, 164 insertions(+), 74 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -1,2 +1,10 @@
*.scrbl~
+
+*.rkt~
+
+*.html
+
+*.css
+
+*.js
diff --git a/afl/docs/docs.scrbl b/afl/docs/docs.scrbl
@@ -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.
+}
+\ No newline at end of file
diff --git a/afl/reader.rkt b/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 #\%])
+
+(module+ test
+ (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)
- (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)))
+ (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
- (require rackunit)
;; 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))))
