commit 64696c77a539d48a558a8f508708c6a59698b7de
Author: AlexKnauth <alexander@knauth.org>
Date: Thu, 10 Jul 2014 17:14:28 -0400
Initial commit
Diffstat:
3 files changed, 204 insertions(+), 0 deletions(-)
diff --git a/afl/lang/reader.rkt b/afl/lang/reader.rkt
@@ -0,0 +1,36 @@
+(module reader racket/base
+ (require syntax/module-reader
+ (only-in "../reader.rkt" make-afl-readtable wrap-reader))
+
+ (provide (rename-out [afl-read read]
+ [afl-read-syntax read-syntax]
+ [afl-get-info get-info]))
+
+ (define-values (afl-read afl-read-syntax afl-get-info)
+ (make-meta-reader
+ 'afl
+ "language path"
+ (lambda (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
+ wrap-reader
+ (lambda (proc)
+ (lambda (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]
+ [else (fallback)]))))))
diff --git a/afl/reader.rkt b/afl/reader.rkt
@@ -0,0 +1,146 @@
+#lang racket/base
+
+(provide make-afl-readtable
+ afl-read
+ afl-read-syntax
+ wrap-reader
+ (rename-out
+ [afl-read read]
+ [afl-read-syntax read-syntax])
+ )
+
+(require racket/match
+ rackjure/threading
+ (only-in racket/port input-port-append)
+ (only-in racket/list remove-duplicates append*)
+ (for-template racket/base)
+ (for-syntax racket/base))
+
+(define (afl-read [in (current-input-port)])
+ (define orig-readtable (current-readtable))
+ (parameterize ([current-readtable (make-afl-readtable orig-readtable)])
+ (read in)))
+
+(define (afl-read-syntax [src (object-name (current-input-port))] [in (current-input-port)])
+ (define orig-readtable (current-readtable))
+ (parameterize ([current-readtable (make-afl-readtable orig-readtable)])
+ (read-syntax src in)))
+
+(define (wrap-reader p)
+ (lambda args
+ (define orig-readtable (current-readtable))
+ (parameterize ([current-readtable (make-afl-readtable orig-readtable)])
+ (apply p args))))
+
+(define (make-afl-readtable [orig-rt (current-readtable)])
+ (define reader-proc (make-reader-proc orig-rt))
+ (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 ((make-reader-proc [orig-rt (current-readtable)])
+ 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))]
+ [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)
+ (with-syntax ([args (parse-args stx)]
+ [%1 (datum->syntax stx '%1 stx)]
+ [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 #'(+))
+ '(lambda ()
+ (define-syntax % (make-rename-transformer #'%1))
+ (+)))
+ (check-equal? (chk #'(+ 2 %1 %1))
+ '(lambda (%1)
+ (define-syntax % (make-rename-transformer #'%1))
+ (+ 2 %1 %1)))
+ (check-equal? (chk #'(+ 2 %3 %2 %1))
+ '(lambda (%1 %2 %3)
+ (define-syntax % (make-rename-transformer #'%1))
+ (+ 2 %3 %2 %1)))
+ (check-equal? (chk #'(apply list* % %&))
+ '(lambda (%1 . %&)
+ (define-syntax % (make-rename-transformer #'%1))
+ (apply list* % %&))))
+
+;; parse-args : Stx -> KW-Formals-Stx
+(define (parse-args stx)
+ ;; 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-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 "%" (number->string n))))
+ (append*
+ (for/list ([kw (in-list kws)])
+ (list kw (string->symbol (string-append "%#:" (keyword->string kw))))))
+ (cond [rest? '%&]
+ [else '()])))
+ (datum->syntax stx datum-kw-formals stx))
+
+;; find-arg-info : Any -> (Values Natural Boolean (Listof Keyword))
+(define (find-arg-info v)
+ (match (maybe-syntax-e v)
+ [(? 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)
+ (match (~> sym symbol->string string->list)
+ [(list) (return)]
+ [(list #\%) (return #:max-num 1)]
+ [(list #\% #\&) (return #:rest? #t)]
+ [(list* #\% #\# #\: cs)
+ (return #:kws (~> cs list->string string->keyword list))]
+ [(list #\% (? char-numeric? cs) ...)
+ (return #:max-num (~> cs list->string string->number))]
+ [_ (return)]))
+
+;; find-arg-info/pair :
+;; (Cons Symbol Symbol) -> (Values Natural Boolean (Listof Keyword))
+(define (find-arg-info/pair pair)
+ (define-values (car.max-num car.rest? car.kws)
+ (find-arg-info (car pair)))
+ (define-values (cdr.max-num cdr.rest? cdr.kws)
+ (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))))
+
+(define (return #:max-num [max-num 0] #:rest? [rest? #f] #:kws [kws '()])
+ (values max-num rest? kws))
+
+(define (maybe-syntax-e stx)
+ (cond [(syntax? stx) (syntax-e stx)]
+ [else stx]))
diff --git a/afl/test.rkt b/afl/test.rkt
@@ -0,0 +1,21 @@
+#lang afl at-exp racket/base
+(require rackunit)
+(check-equal? (map #λ(+ % 1) '(1 2 3))
+ '(2 3 4))
+(check-equal? (map #λ(+ % %2) '(1 2 3) '(1 2 3))
+ '(2 4 6))
+(check-equal? (#λ(apply list* % %&) 1 '(2 3))
+ '(1 2 3))
+(check-equal? (#λ(* 1/2 %#:m (* %#:v %#:v)) #:m 2 #:v 1)
+ 1)
+(check-equal? (let ([x (#λ"I am x")])
+ (#λx))
+ "I am x")
+(check-equal? (#λ(begin (set! % "%") %1) "%1")
+ "%")
+(check-equal? (map #λ@+[% 1] '(1 2 3))
+ '(2 3 4))
+(check-equal? @#λ(+ % 1)[1]
+ 2)
+(check-equal? @#λ@+[% 1][1]
+ 2)
+\ No newline at end of file
