From 617496f14e74bf731bfd44b7ed32745f7e9727ac Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 7 Sep 2010 18:50:42 -0400 Subject: [PATCH] Make syntax of #{} less accepting of errors. original commit: 91fefa055ea0b0fda8ae8bffb993bc163e4160af --- .../typed-scheme/succeed/basic-tests.rkt | 10 +-- .../succeed/match-expander-problem.rkt | 2 +- .../tests/typed-scheme/succeed/stream.rkt | 66 +++++++++++++++++++ .../typed-scheme/private/type-annotation.rkt | 5 +- collects/typed-scheme/typed-reader.rkt | 8 ++- 5 files changed, 79 insertions(+), 12 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/stream.rkt diff --git a/collects/tests/typed-scheme/succeed/basic-tests.rkt b/collects/tests/typed-scheme/succeed/basic-tests.rkt index 7fb9cfb9..f127a11b 100644 --- a/collects/tests/typed-scheme/succeed/basic-tests.rkt +++ b/collects/tests/typed-scheme/succeed/basic-tests.rkt @@ -17,7 +17,7 @@ #;(define: match-test : number (match 3 - [(? number? #{x number}) (+ 17 x)] + [(? number? #{x : number}) (+ 17 x)] [_ 12])) @@ -45,7 +45,7 @@ #;(define: (pt-add/match [v : top]) : number (match v - [($ pt #{x number} #{y number}) (+ x y)] + [($ pt #{x : number} #{y : number}) (+ x y)] [_ 0])) #;(pt-add/match x-struct) @@ -77,9 +77,9 @@ (define: (f [x : number] [y : number]) : number (+ x y)) (define: (g [x : number] [y : number]) : boolean - (let+ (#;[val #{z number} #f] - [val #{x1 number} (* x x)] - [rec #{y1 number} (* y y)]) + (let+ (#;[val #{z : number} #f] + [val #{x1 : number} (* x x)] + [rec #{y1 : number} (* y y)]) #|(define-syntax foo (syntax-rules () [(foo) (= x1 y1)])) diff --git a/collects/tests/typed-scheme/succeed/match-expander-problem.rkt b/collects/tests/typed-scheme/succeed/match-expander-problem.rkt index dd563dfc..dc6400e6 100644 --- a/collects/tests/typed-scheme/succeed/match-expander-problem.rkt +++ b/collects/tests/typed-scheme/succeed/match-expander-problem.rkt @@ -14,7 +14,7 @@ (define: (pt-add/match/blah [v : Any]) : Number (match v - [(blah pt #{x Number} #{y Number}) (+ x y)] + [(blah pt #{x : Number} #{y : Number}) (+ x y)] [_ 0])) diff --git a/collects/tests/typed-scheme/succeed/stream.rkt b/collects/tests/typed-scheme/succeed/stream.rkt new file mode 100644 index 00000000..afedf86e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/stream.rkt @@ -0,0 +1,66 @@ +#lang typed/racket +#:optimize + +(provide Stream stream-cons stream-car stream-cdr empty-stream?) + +(define-type Stream + (All (A) + (Rec S + (U Null (Boxof (U (-> (Pair A S)) + (Pair A S))))))) + +(: empty-stream? : (All (A) ((Stream A) -> Boolean))) +(define (empty-stream? stream) (null? stream)) + +(define-syntax-rule (stream-cons x stream) + (box (lambda () (cons x stream)))) + +(: stream-car : (All (A) ((Stream A) -> A))) +(define (stream-car stream) + (if (null? stream) + (error 'stream-car "empty stream: ~e" stream) + (let ([p (unbox stream)]) + (if (procedure? p) + (let ([pair (p)]) + (set-box! stream pair) + (car pair)) + (car p))))) + +(: stream-cdr : (All (A) ((Stream A) -> (Stream A)))) +(define (stream-cdr stream) + (if (null? stream) + (error 'stream-cdr "empty stream: ~e" stream) + (let ([p (unbox stream)]) + (if (procedure? p) + (let ([pair (p)]) + (set-box! stream pair) + (cdr pair)) + (cdr p))))) + +(: stream : (All (A) (A * -> (Stream A)))) +(define (stream . xs) + (: loop : (All (A) ((Listof A) -> (Stream A)))) + (define (loop xs) + (if (null? xs) + '() + (box (cons (car xs) (loop (cdr xs)))))) + (loop xs)) + +(: stream->list : (All (A) ((Stream A) -> (Listof A)))) +(define (stream->list stream) + (if (null? stream) + '() + (cons (stream-car stream) (stream->list (stream-cdr stream))))) + +(: rotate : (All (A) ((Stream A) (Listof A) (Stream A) -> (Stream A)))) +(define (rotate frnt rer accum) + (let ([carrer (car rer)]) + ;; Manually expanded `stream-cons', and added type annotations + (if (empty-stream? frnt) + (stream-cons carrer accum) + (stream-cons + (stream-car frnt) + ((inst rotate A) + (stream-cdr frnt) + (cdr rer) + (box (lambda () (cons carrer accum)))))))) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-scheme/private/type-annotation.rkt index e5ab42be..5dd07fe7 100644 --- a/collects/typed-scheme/private/type-annotation.rkt +++ b/collects/typed-scheme/private/type-annotation.rkt @@ -30,7 +30,7 @@ (printf/log "Annotation Sexp Pair \n") (print-size #'a) (print-size #'b))] - [_ (printf/log "Annotation Sexp \n" )])) + [_ (printf/log "Annotation Sexp \n")])) ;; get the type annotation of this syntax ;; syntax -> Maybe[Type] @@ -62,7 +62,6 @@ (define (type-ascription stx) (define (pt prop) - #;(print-size prop) (if (syntax? prop) (parse-tc-results prop) (parse-tc-results/id stx prop))) @@ -72,7 +71,7 @@ (lambda (prop) (if (pair? prop) (pt (car prop)) - (pt prop)))] + (pt prop)))] [else #f])) (define (remove-ascription stx) diff --git a/collects/typed-scheme/typed-reader.rkt b/collects/typed-scheme/typed-reader.rkt index 2d4e2efa..810aa6e8 100644 --- a/collects/typed-scheme/typed-reader.rkt +++ b/collects/typed-scheme/typed-reader.rkt @@ -51,11 +51,13 @@ (let* ([prop-name (syntax-e (read-one))]) (skip-whitespace port) (syntax-property name prop-name (read-one)))] - ;; type annotation - [else (syntax-property name 'type-label (syntax->datum next))]))) + ;; otherwise error + [else + (let-values ([(l c p) (port-next-location port)]) + (raise-read-error (format "typed expression ~a must be followed by :, ::, or @" + (syntax->datum name)) src l c p 1))]))) (skip-whitespace port) (let ([c (read-char port)]) - #;(printf "char: ~a" c) (unless (equal? #\} c) (let-values ([(l c p) (port-next-location port)]) (raise-read-error (format "typed expression ~a not properly terminated" (syntax->datum name)) src l c p 1)))))))