diff --git a/.gitignore b/.gitignore index d6812e0..b28a785 100644 --- 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 index 55602ba..b951a49 100644 --- 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 index d68adb1..59eb7fe 100644 --- 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 #\%]) - 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))))