From 0145f047ffa8c3d4737ba39a8c89a44d1bf02a69 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 12 Dec 2012 14:19:14 -0500 Subject: [PATCH] Allow `#:unless' in `for:'. Also allow `#:break' and `#:final' in all the `for:' macros. Unfortunately, the expansion of `#:break' and `#:final' cannot be typechecked at the moment. original commit: ec673fd58d3e24e999426e4bc07d72a05e3a099b --- collects/tests/typed-racket/succeed/for.rkt | 25 +++++ .../typed-racket/base-env/for-clauses.rkt | 53 ++++------- collects/typed-racket/base-env/prims.rkt | 92 +++++++++++-------- 3 files changed, 94 insertions(+), 76 deletions(-) diff --git a/collects/tests/typed-racket/succeed/for.rkt b/collects/tests/typed-racket/succeed/for.rkt index e2a79278..6b2267d3 100644 --- a/collects/tests/typed-racket/succeed/for.rkt +++ b/collects/tests/typed-racket/succeed/for.rkt @@ -199,3 +199,28 @@ ([i : Natural (ann 4 Integer)]) i) 6) + +(check string=? + (with-output-to-string + (lambda () + (for: ([x 10] #:unless (> x 3)) (display x)))) + "0123") + +;; break and final clauses +;; TODO typechecker can't handle these +;; (check string=? +;; (with-output-to-string +;; (lambda () +;; (for: ([x 10] #:break (> x 3)) (display x)))) +;; "0123") +;; (check string=? +;; (with-output-to-string +;; (lambda () +;; (for: ([x 10]) #:break (> x 3) (display x)))) +;; "0123") +;; (check = +;; (for/sum: : Integer ([x : Integer 10] #:break (> x 3)) (ann x Integer)) +;; 6) +;; (check = +;; (for/sum: : Integer ([x 10] #:final (> x 3)) x) +;; 10) diff --git a/collects/typed-racket/base-env/for-clauses.rkt b/collects/typed-racket/base-env/for-clauses.rkt index a9c3acb2..3e36b812 100644 --- a/collects/typed-racket/base-env/for-clauses.rkt +++ b/collects/typed-racket/base-env/for-clauses.rkt @@ -6,41 +6,22 @@ (provide (all-defined-out)) -(define-splicing-syntax-class for-clause - ;; single-valued seq-expr - (pattern (~and c (var:optionally-annotated-name seq-expr:expr)) - #:with (expand ...) (list (syntax/loc - #'c - (var.ann-name seq-expr)))) - ;; multi-valued seq-expr - ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern (~and c (((v:optionally-annotated-name) ...) seq-expr:expr)) - #:with (expand ...) (list (syntax/loc - #'c - ((v.ann-name ...) seq-expr)))) - ;; when clause - (pattern (~seq #:when guard:expr) - #:with (expand ...) (list #'#:when #'guard)) - (pattern (~seq #:unless guard:expr) - #:with (expand ...) (list #'#:unless #'guard))) - ;; intersperses "#:when #t" clauses to emulate the for* variants' semantics -(define-splicing-syntax-class for*-clause +(define-splicing-syntax-class for-clause ;; single-valued seq-expr - (pattern (~and c (var:optionally-annotated-name seq-expr:expr)) - #:with (expand ...) (list (syntax/loc - #'c - (var.ann-name seq-expr)) - #'#:when #'#t)) - ;; multi-valued seq-expr - ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern (~and c (((v:optionally-annotated-name) ...) seq-expr:expr)) - #:with (expand ...) (list (quasisyntax/loc - #'c - ((v.ann-name ...) seq-expr)) - #'#:when #'#t)) - ;; when clause - (pattern (~seq #:when guard:expr) - #:with (expand ...) (list #'#:when #'guard)) - (pattern (~seq #:unless guard:expr) - #:with (expand ...) (list #'#:unless #'guard))) + (pattern (~and c (var:optionally-annotated-name seq-expr:expr)) + #:with (expand ...) #`(#,(syntax/loc #'c + (var.ann-name seq-expr))) + #:with (expand* ...) #'(expand ... #:when #t)) + ;; multi-valued seq-expr + ;; currently disabled because it triggers an internal error in the typechecker + ;; (pattern (~and c (((v:optionally-annotated-name) ...) seq-expr:expr)) + ;; #:with (expand ...) (list (syntax/loc #'c + ;; ((v.ann-name ...) seq-expr))) + ;; #:with (expand* ...) (list (quasisyntax/loc #'c + ;; ((v.ann-name ...) seq-expr)) + ;; #'#:when #'#t)) + ;; Note: #:break and #:final clauses don't ever typecheck + (pattern (~seq (~and kw (~or #:when #:unless #:break #:final)) guard:expr) + #:with (expand ...) (list #'kw #'guard) + #:with (expand* ...) #'(expand ...))) diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt index f0a7c21f..4754d532 100644 --- a/collects/typed-racket/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -695,44 +695,54 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; the annotation is not necessary (always of Void type), but kept ;; for consistency with the other for: macros [(_ (~seq : Void) ... - clauses ; no need to annotate the type, it's always Void - c:expr ...) - (let ((body (syntax-property #'(c ...) 'type-ascription #'Void))) + ;; c is not always an expression, could be a break-clause + clauses c ...) ; no need to annotate the type, it's always Void + (let ((body #`(; break-clause ... + #,@(syntax-property #'(c ...) 'type-ascription #'Void)))) (let loop ((clauses #'clauses)) - (define-syntax-class for-clause + (define-splicing-syntax-class for-clause ;; single-valued seq-expr ;; unlike the definitions in for-clauses.rkt, this does not include ;; #:when clauses, which are handled separately here - (pattern (var:optionally-annotated-name seq-expr:expr) - #:with expand #'(var.ann-name seq-expr)) + (pattern (~seq (var:optionally-annotated-name seq-expr:expr)) + #:with (expand ...) #'((var.ann-name seq-expr))) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern ((v:optionally-annotated-name ...) seq-expr:expr) - #:with expand #'((v.ann-name ...) seq-expr))) + ;; (pattern ((v:optionally-annotated-name ...) seq-expr:expr) + ;; #:with (expand ...) #'(((v.ann-name ...) seq-expr))) + ;; break-clause, pass it directly + ;; Note: these don't ever typecheck + (pattern (~seq (~and kw (~or #:break #:final)) guard-expr:expr) + #:with (expand ...) #'(kw guard-expr))) + (define-syntax-class for-kw + (pattern #:when + #:with replace-with #'when) + (pattern #:unless + #:with replace-with #'unless)) (syntax-parse clauses - [(head:for-clause next:for-clause ... #:when rest ...) + [(head:for-clause next:for-clause ... kw:for-kw rest ...) (syntax-property (quasisyntax/loc stx (for - (head.expand next.expand ...) - #,(loop #'(#:when rest ...)))) + (head.expand ... next.expand ... ...) + #,(loop #'(kw rest ...)))) 'type-ascription #'Void)] [(head:for-clause ...) ; we reached the end (syntax-property (quasisyntax/loc stx (for - (head.expand ...) + (head.expand ... ...) #,@body)) 'type-ascription #'Void)] - [(#:when guard) ; we end on a #:when clause + [(kw:for-kw guard) ; we end on a keyword clause (quasisyntax/loc stx - (when guard + (kw.replace-with guard #,@body))] - [(#:when guard rest ...) + [(kw:for-kw guard rest ...) (quasisyntax/loc stx - (when guard + (kw.replace-with guard #,(loop #'(rest ...))))])))])) (define-for-syntax (maybe-annotate-body body ty) @@ -751,7 +761,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ a:optional-standalone-annotation (clause:for-clause ...) - c:expr ...) + c ...) ; c is not always an expression, can be a break-clause (maybe-annotate-body (quasisyntax/loc stx (#,name @@ -783,7 +793,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ : ty ((var:optionally-annotated-name) ...) (clause:for-clause ...) - c:expr ...) + c ...) ; c is not always an expression, can be a break-clause (syntax-property (quasisyntax/loc stx (for/lists (var.ann-name ...) @@ -793,7 +803,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #'ty)] [(_ ((var:annotated-name) ...) (clause:for-clause ...) - c:expr ...) + c ...) (syntax-property (quasisyntax/loc stx (for/lists (var.ann-name ...) @@ -806,7 +816,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ : ty ((var:optionally-annotated-name init:expr) ...) (clause:for-clause ...) - c:expr ...) + c ...) ; c is not always an expression, can be a break-clause (syntax-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) @@ -816,7 +826,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #'ty)] [(_ ((var:annotated-name init:expr) ...) (clause:for-clause ...) - c:expr ...) + c ...) (syntax-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) @@ -829,10 +839,10 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (for*: stx) (syntax-parse stx #:literals (:) [(_ (~seq : Void) ... - (clause:for*-clause ...) - c:expr ...) + (clause:for-clause ...) + c ...) ; c is not always an expression, can be a break-clause (quasisyntax/loc stx - (for: (clause.expand ... ...) + (for: (clause.expand* ... ...) c ...))])) ;; These currently only typecheck in very limited cases. @@ -841,7 +851,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ a:optional-standalone-annotation (clause:for-clause ...) - c:expr ...) + c ...) ; c is not always an expression, can be a break-clause (maybe-annotate-body (quasisyntax/loc stx (#,name (clause.expand ... ...) @@ -867,22 +877,22 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ : ty ((var:optionally-annotated-name) ...) - (clause:for*-clause ...) - c:expr ...) + (clause:for-clause ...) + c ...) ; c is not always an expression, can be a break-clause (syntax-property (quasisyntax/loc stx (for/lists (var.ann-name ...) - (clause.expand ... ...) + (clause.expand* ... ...) c ...)) 'type-ascription #'ty)] [(_ ((var:annotated-name) ...) - (clause:for*-clause ...) - c:expr ...) + (clause:for-clause ...) + c ...) (syntax-property (quasisyntax/loc stx (for/lists (var.ann-name ...) - (clause.expand ... ...) + (clause.expand* ... ...) c ...)) 'type-ascription #'(values var.ty ...))])) @@ -890,22 +900,22 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ : ty ((var:optionally-annotated-name init:expr) ...) - (clause:for*-clause ...) - c:expr ...) + (clause:for-clause ...) + c ...) ; c is not always an expression, can be a break-clause (syntax-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) - (clause.expand ... ...) + (clause.expand* ... ...) c ...)) 'type-ascription #'ty)] [(_ ((var:annotated-name init:expr) ...) - (clause:for*-clause ...) - c:expr ...) + (clause:for-clause ...) + c ...) (syntax-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) - (clause.expand ... ...) + (clause.expand* ... ...) c ...)) 'type-ascription #'(values var.ty ...))])) @@ -916,7 +926,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ : ty (clause:for-clause ...) - c:expr ...) + c ...) ; c is not always an expression, can be a break-clause ;; ty has to include exact 0, the initial value of the accumulator ;; (to be consistent with Racket semantics). ;; We can't just change the initial value to be 0.0 if we expect a @@ -940,7 +950,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) ((_ (~seq : return-annotation:expr) - (bind:optionally-annotated-binding ...) body:expr ...) + (bind:optionally-annotated-binding ...) + body ...) ; body is not always an expression, can be a break-clause (quasisyntax/loc stx (for/fold: : return-annotation ((return-hash : return-annotation (ann (#,hash-maker null) return-annotation))) @@ -957,7 +968,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) ((_ (~seq : return-annotation:expr) - (bind:optionally-annotated-binding ...) body:expr ...) + (bind:optionally-annotated-binding ...) + body ...) ; body is not always an expression, can be a break-clause (quasisyntax/loc stx (for*/fold: : return-annotation ((return-hash : return-annotation (ann (#,hash-maker null) return-annotation)))