commit 92adcde5d4475f7eb9656a23d2a7a7d6e64bb07e
parent a9d3bf1be98f38be1b54caa1975b11843646c7a6
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 30 Mar 2016 17:47:21 +0200
First working version, when run interactively (press F5 in drracket).
Diffstat:
| M | lang/reader.rkt | | | 230 | ++++++++++++++++++++++++++----------------------------------------------------- |
| M | test/test.rkt | | | 20 | ++++++++------------ |
2 files changed, 83 insertions(+), 167 deletions(-)
diff --git a/lang/reader.rkt b/lang/reader.rkt
@@ -4,143 +4,94 @@
[repltest-read-syntax read-syntax]
[repltest-get-info get-info]))
-(require syntax/module-reader)
+(require syntax/module-reader
+ racket/syntax
+ rackunit)
-#;(define (repltest-read in)
- (syntax->datum
- (repltest-read-syntax #f in)))
+(define (read-pre-prompt in)
+ (regexp-try-match #px"^\\s*" in))
-(define (read-prompt in)
- (regexp-try-match #px"^\\s*[0-9]> " in))
+(define (read-actual-prompt in)
+ (regexp-try-match #px"^> " in))
-(define (read-user-input reader args)
- (apply reader args))
+(define (peak-prompt in)
+ (regexp-try-match #px"^\\s*> " (peeking-input-port in)))
-(define (read-output-values reader args in)
- (if (read-prompt in)
- '()
- (let ([rs (apply reader args)])
- (if (eof-object? rs)
- '()
- (read-output-values reader args in)))))
+(define (skip-newline in)
+ (regexp-try-match #px"^\n" in))
-#;(let ([is (open-input-string "(+ 1 1) 'aaa")]
- [os (open-output-string)])
- (parameterize ([current-get-interaction-input-port
- (λ () is)]
- [current-namespace (make-base-namespace)]
- [current-output-port os]
- [current-error-port os]
- [current-print (λ (v)
- (unless (void? v)
- (print v)
- (newline)))])
- (read-eval-print-loop))
-
- (display (get-output-string os)))
-
-
-
-#;(define-values (wrap-read wrap-read-syntax)
- (let ()
- (define (wrap default-reader reader src in . args)
- ;(displayln (apply default-reader args))
- ;((λ (x) (displayln x) x) (apply reader args))
- (displayln args)
- ((λ (x) (displayln x) x)
- (apply reader src in (cddr args)));;TODO: not cddr for read
- #;#`(module m typed/racket
- '#,(default-reader src in))
- #;(let* ([in (if (null? (cdr args)) (car args) (cadr args))]
- [maybe-prompt (read-prompt in)])
- (if maybe-prompt
- ((λ (x) (displayln x) x) (apply reader args))
- ((λ (x) (displayln x) x) (apply reader args))))
- #;(let* ([in (if (null? (cdr args)) (car args) (cadr args))]
- [first-prompt (read-prompt in)]
- [user-input (read-user-input reader args)]
- [output-values (read-output-values reader args in)])
- (if first-prompt
- #`(module anything racket
- '(check-equal? #,user-input
- (values . #,output-values))
- (let ([os (open-output-string)])
- (parameterize ([current-input-port (open-input-string "")]
- [current-output-port os])
- 'todo
- (get-output-string os))))
- #'(module anything racket #f))))
- (values (λ (reader)
- (λ args
- (apply wrap read reader #f (car args) args)))
- (λ (reader)
- (λ args
- (apply wrap
- read-syntax
- reader
- (car args)
- (cadr args)
- args))))))
+(define (peek-read-length in)
+ (let* ([pk (peeking-input-port in)]
+ [start (file-position pk)]
+ [r (read pk)]
+ [end (file-position pk)])
+ (- end start)))
-(define (read-one-interaction src in)
- (let ([prompt (read-prompt in)])
- (if (not prompt)
- (values eof #f '())
- (let ([user-input (read-syntax src in)]
- [output-values (let loop ()
- (if (read-prompt (peeking-input-port in))
- '()
- (let ([val (read-syntax src in)])
- (if (eof-object? val)
- '()
- (cons val (loop))))))])
- (if (eof-object? user-input)
- (values (car prompt) #f '())
- (values (car prompt) user-input output-values))))))
+(define (narrow-next-read in)
+ (make-limited-input-port in (peek-read-length in)))
-(define ((wrap-reader reader) chr in src line col pos)
+(define (peak-until-prompt-length in)
(let* ([pk (peeking-input-port in)]
[start (file-position pk)]
[end (let loop ()
- (let* ([pos (file-position pk)]
- [pr (read-prompt pk)])
+ (let* ([pre (read-pre-prompt pk)]
+ [pos (file-position pk)]
+ [pr (read-actual-prompt pk)])
(if (or pr (eof-object? (read pk)))
pos
(loop))))])
- (with-syntax ([(mod nm . body)
- (reader chr
- (make-limited-input-port in (- end start))
- src line col pos)])
- (let loop ()
- (let-values ([(p u o) (read-one-interaction src in)])
- (when u
- ;(display p)
- ;(displayln (syntax->datum u))
- ;(map displayln (map syntax->datum o))
- (loop))))
- ;; Run interactions:
- (let ([is (open-input-string "x y (number->string (+ 1 1))")]
- [os (open-output-string)]
- [ns (make-base-namespace)])
- (eval #'(mod nm . body) ns)
- ;; This is a hack because I can't get (module->namespace ''m) to work:
- (define mod-ns (eval #'(begin (require racket/enter)
- (enter! 'nm #:dont-re-require-enter)
- (current-namespace))
- ns))
- (parameterize ([current-get-interaction-input-port
- (λ () is)]
- [current-namespace mod-ns]
- [current-output-port os]
- [current-error-port os]
- [current-print (λ (v)
- (unless (void? v)
- (print v)
- (newline)))])
- (read-eval-print-loop))
-
- (display (get-output-string os)))
- #'(mod nm racket) #;#'(mod nm . body))))
+ (- end start)))
+
+(define (narrow-until-prompt in)
+ (make-limited-input-port in (peak-until-prompt-length in)))
+
+(define silent-prompt-read
+ (λ ()
+ ;; Default current-prompt-read, without showing
+ ;; the prompt
+ (let ([in ((current-get-interaction-input-port))])
+ ((current-read-interaction) (object-name in) in))))
+
+(define (run-interactions mod-stx in-rest)
+ (define/with-syntax (mod nm . body) mod-stx)
+ (let ([ns (make-base-namespace)])
+ (eval mod-stx ns)
+ ;; This is a hack because I can't get (module->namespace ''m) to work:
+ (define mod-ns (eval #'(begin (require racket/enter)
+ (enter! 'nm #:dont-re-require-enter)
+ (current-namespace))
+ ns))
+ (let loop ()
+ (let* ([pr (read-actual-prompt in-rest)])
+ (when pr
+ (let* ([narrowed (narrow-next-read in-rest)]
+ [os (open-output-string)]
+ [actual (parameterize
+ ([current-prompt-read
+ silent-prompt-read]
+ [current-get-interaction-input-port
+ (λ () narrowed)]
+ [current-namespace mod-ns]
+ [current-output-port os]
+ [current-error-port os]
+ [current-print (λ (v)
+ (unless (void? v)
+ (print v)
+ (newline)))])
+ (read-eval-print-loop)
+ (get-output-string os))]
+ [skip (skip-newline in-rest)]
+ [expected (port->string (narrow-until-prompt in-rest))])
+ (check-equal? actual
+ expected))
+ (loop))))))
+
+(define ((wrap-reader reader) chr in src line col pos)
+ (define/with-syntax (mod nm . body)
+ (reader chr (narrow-until-prompt in) src line col pos))
+ ;; Run interactions:
+ (run-interactions #'(mod nm . body) in)
+ #'(mod nm . body))
(define-values (repltest-read repltest-read-syntax repltest-get-info)
(make-meta-reader
@@ -162,33 +113,3 @@
(define (fallback) (if proc (proc key defval) defval))
(case key
[else (fallback)])))))
-
-
-#|
-#lang racket
-(let ([is (open-input-string "x y (number->string (+ 1 1))")]
- [os (open-output-string)]
- [ns (make-base-namespace)])
- (eval #'(module m typed/racket
- (define x 0)
- (define y 1)
- 'displayed
- (displayln "aaaa"))
- ns)
- (define mod-ns (eval #'(begin (require racket/enter)
- (enter! 'm #:dont-re-require-enter)
- (current-namespace))
- ns))
- (parameterize ([current-get-interaction-input-port
- (λ () is)]
- [current-namespace mod-ns]
- [current-output-port os]
- [current-error-port os]
- [current-print (λ (v)
- (unless (void? v)
- (print v)
- (newline)))])
- (read-eval-print-loop))
-
- (display (get-output-string os)))
-|#
-\ No newline at end of file
diff --git a/test/test.rkt b/test/test.rkt
@@ -6,20 +6,17 @@
'displayed
(displayln "displayed too")
-1> (+ 1 1)
+> (+ 1 1)
+- : Integer [more precisely: Positive-Index]
2
-2> x
+> x
+- : Integer [more precisely: Zero]
0
-
-3> (values x y)
+> (values x y)
+- : (values Integer Integer) [more precisely: (Values Zero One)]
0
1
-4> #R(+ 2 0)
+> #R(+ 2 0)
(+ 2 0) = 2
+- : Integer [more precisely: Positive-Byte]
2
-
-#|
-(values (+ 1 1) 4)
-#R(+ 2 0)
-4
-|#
-\ No newline at end of file
