Add flatten-all-begins to syntax/flatten-begin

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]

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)

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)))))