Initial commit

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)]))))))

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]))

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)