Initial commit
This commit is contained in:
commit
64696c77a5
36
afl/lang/reader.rkt
Normal file
36
afl/lang/reader.rkt
Normal file
|
@ -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)]))))))
|
146
afl/reader.rkt
Normal file
146
afl/reader.rkt
Normal file
|
@ -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]))
|
21
afl/test.rkt
Normal file
21
afl/test.rkt
Normal file
|
@ -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)
|
Loading…
Reference in New Issue
Block a user