diff --git a/pkgs/racket-pkgs/racket-doc/syntax/scribblings/flatten-begin.scrbl b/pkgs/racket-pkgs/racket-doc/syntax/scribblings/flatten-begin.scrbl index 2cb9e3dd75..3f6b83ecf1 100644 --- a/pkgs/racket-pkgs/racket-doc/syntax/scribblings/flatten-begin.scrbl +++ b/pkgs/racket-pkgs/racket-doc/syntax/scribblings/flatten-begin.scrbl @@ -1,5 +1,10 @@ #lang scribble/doc -@(require "common.rkt" (for-label syntax/flatten-begin)) +@(require "common.rkt" + scribble/eval + (for-label syntax/flatten-begin)) + +@(define flatten-eval (make-base-eval)) +@(flatten-eval '(require syntax/flatten-begin)) @title[#:tag "flatten-begin"]{Flattening @racket[begin] Forms} @@ -11,3 +16,20 @@ Extracts the sub-expressions from a @racket[begin]-like form, reporting an error if @racket[stx] does not have the right shape (i.e., a syntax list). The resulting syntax objects have annotations transferred from @racket[stx] using @racket[syntax-track-origin].} + +@defproc[(flatten-all-begins [stx syntax?]) (listof syntax?)]{ + +Extracts the sub-expressions from a @racket[begin] form and +recursively flattens @racket[begin] forms nested in the original one. +An error will be reported if @racket[stx] is not a @racket[begin] +form. The resulting syntax objects have annotations +transferred from @racket[stx] using @racket[syntax-track-origin]. + +@examples[#:eval flatten-eval + (flatten-all-begins #'(begin 1 2 3)) + (flatten-all-begins #'(begin (begin 1 2) 3)) +] + +@history[#:added "6.1.0.3"]} + +@close-eval[flatten-eval] diff --git a/pkgs/racket-pkgs/racket-test/tests/syntax/flatten-begin.rkt b/pkgs/racket-pkgs/racket-test/tests/syntax/flatten-begin.rkt new file mode 100644 index 0000000000..184207762b --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/syntax/flatten-begin.rkt @@ -0,0 +1,26 @@ +#lang racket/base + +;; Tests for syntax/flatten-begin + +(require rackunit + rackunit/text-ui + syntax/flatten-begin) + +(define-binary-check (check-equal-datum? actual expected) + (check-equal? (map syntax->datum actual) + (map syntax->datum expected))) + +(define-test-suite flatten-all-begins-tests + (check-exn exn:fail:syntax? (λ () (flatten-all-begins #'(1 2 3)))) + (check-equal-datum? (flatten-all-begins #'(begin 1 2 3)) + (list #'1 #'2 #'3)) + (check-equal-datum? (flatten-all-begins #'(begin (begin 1 2) 3)) + (list #'1 #'2 #'3)) + (check-equal-datum? (flatten-all-begins #'(begin (begin 1 2) (+ 3 4) 5)) + (list #'1 #'2 #'(+ 3 4) #'5)) + (check-equal-datum? (flatten-all-begins #'(begin (begin 1 (begin 2) 3) 4)) + (list #'1 #'2 #'3 #'4)) + (check-equal-datum? (flatten-all-begins #'(begin (begin 1 2) (begin 3) 4)) + (list #'1 #'2 #'3 #'4))) + +(run-tests flatten-all-begins-tests) diff --git a/racket/collects/syntax/flatten-begin.rkt b/racket/collects/syntax/flatten-begin.rkt index 204f357468..76aefcf15b 100644 --- a/racket/collects/syntax/flatten-begin.rkt +++ b/racket/collects/syntax/flatten-begin.rkt @@ -1,5 +1,6 @@ #lang racket/base -(provide flatten-begin) +(provide flatten-begin + flatten-all-begins) (define (flatten-begin stx) (let ([l (syntax->list stx)]) @@ -11,3 +12,23 @@ #f "bad syntax" stx)))) + +;; flatten-all-begins : Syntax -> (Listof Syntax) +;; Flatten `begin` expressions recursively +(define (flatten-all-begins orig-stx) + (define val (syntax-e orig-stx)) + (unless (and (pair? val) + (not (null? val)) + (identifier? (car val)) + (free-identifier=? (car val) #'begin)) + (raise-syntax-error + #f + "not a begin expression" + orig-stx)) + (let loop ([stx orig-stx]) + (define lst (syntax->list stx)) + (if (and lst + (not (null? lst)) + (free-identifier=? (car lst) #'begin)) + (apply append (map loop (cdr lst))) + (list (syntax-track-origin stx orig-stx #'begin)))))