From bfda0665de6a3848a4201f88d1e7212002cf7776 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 13 Jan 2014 18:08:35 -0700
Subject: [PATCH] add syntax/wrap-modbeg

---
 .../syntax/scribblings/module-helpers.scrbl   |   1 +
 .../syntax/scribblings/wrap-modbeg.scrbl      |  28 ++++
 racket/collects/racket/private/modbeg.rkt     | 140 ++---------------
 racket/collects/syntax/wrap-modbeg.rkt        | 144 ++++++++++++++++++
 4 files changed, 187 insertions(+), 126 deletions(-)
 create mode 100644 pkgs/racket-pkgs/racket-doc/syntax/scribblings/wrap-modbeg.scrbl
 create mode 100644 racket/collects/syntax/wrap-modbeg.rkt

diff --git a/pkgs/racket-pkgs/racket-doc/syntax/scribblings/module-helpers.scrbl b/pkgs/racket-pkgs/racket-doc/syntax/scribblings/module-helpers.scrbl
index 8fe1037c01..f5fedd6dfd 100644
--- a/pkgs/racket-pkgs/racket-doc/syntax/scribblings/module-helpers.scrbl
+++ b/pkgs/racket-pkgs/racket-doc/syntax/scribblings/module-helpers.scrbl
@@ -8,3 +8,4 @@
 @include-section["modresolve.scrbl"]
 @include-section["modcollapse.scrbl"]
 @include-section["moddep.scrbl"]
+@include-section["wrap-modbeg.scrbl"]
\ No newline at end of file
diff --git a/pkgs/racket-pkgs/racket-doc/syntax/scribblings/wrap-modbeg.scrbl b/pkgs/racket-pkgs/racket-doc/syntax/scribblings/wrap-modbeg.scrbl
new file mode 100644
index 0000000000..9b87174578
--- /dev/null
+++ b/pkgs/racket-pkgs/racket-doc/syntax/scribblings/wrap-modbeg.scrbl
@@ -0,0 +1,28 @@
+#lang scribble/doc
+@(require "common.rkt" (for-label syntax/wrap-modbeg))
+
+@title[#:tag "wrap-modbeg"]{Wrapping Module-Body Expressions}
+
+@defmodule[syntax/wrap-modbeg]
+
+@history[#:added "6.0.0.1"]
+
+@defproc[(make-wrapping-module-begin [wrap-form syntax?]
+                                     [module-begin-form syntax? #'#%plain-module-begin])
+         (syntax? . -> . syntax?)]{
+
+Provided @racket[for-syntax].
+
+Constructs a function that is suitable for use as a
+@racket[#%module-begin] replacement, particularly to replace the
+facet of @racket[#%module-begin] that wraps each top-level
+expression to print the expression's result(s).
+
+The function takes a syntax object and returns a syntax object using
+@racket[module-begin-form].  Assuming that @racket[module-begin-form]
+resembles @racket[#%plain-module-begin], each top-level expression
+@racket[_expr] will be wrapped as @racket[(wrap-form _expr)], while
+top-level declarations (such as @racket[define-values] and
+@racket[require] forms) are left as-is. Expressions are detected after
+macro expansion and @racket[begin] splicing, and expansion is
+interleaved with declaration processing as usual.}
diff --git a/racket/collects/racket/private/modbeg.rkt b/racket/collects/racket/private/modbeg.rkt
index 1213c656ba..72e7c3fe09 100644
--- a/racket/collects/racket/private/modbeg.rkt
+++ b/racket/collects/racket/private/modbeg.rkt
@@ -2,7 +2,8 @@
 ;;  `print-value'.
 
 (module modbeg '#%kernel
-  (#%require (for-syntax '#%kernel))
+  (#%require syntax/wrap-modbeg
+             (for-syntax '#%kernel))
 
   (#%provide module-begin)
 
@@ -12,130 +13,17 @@
       (apply values vs)))
 
   (define-syntaxes (module-begin)
-    (lambda (stx)
-      (if (eq? 'module-begin (syntax-local-context))
-          (void)
-          (raise-syntax-error
-           #f
-           "allowed only around a module body"
-           stx))
-      (if (symbol? (syntax-e stx))
-          (raise-syntax-error
-           #f
-           "bad syntax" 
-           stx)
-          (void))
-      (let-values ([(l) (syntax->list stx)])
-        (if l
-            (void)
-            (raise-syntax-error
-             #f
-             "bad syntax (illegal use of `.')" 
-             stx))
-        (datum->syntax
-         stx
-         (cons (quote-syntax #%module-begin)
-               (map (lambda (e)
-                      (list (quote-syntax printing-module-begin)
-                            e))
-                    (cdr l)))
-         stx
-         stx))))
+    (make-wrapping-module-begin (quote-syntax print-result)))
 
-  (define-syntaxes (printing-module-begin)
+  (define-syntaxes (print-result)
     (lambda (stx)
-      (let-values ([(r) (cdr (syntax-e stx))])
-        (let-values ([(r) (if (syntax? r)
-                              (syntax-e r)
-                              r)])
-          (if (null? r)
-              (quote-syntax (void))
-              (let-values ([(e) (local-expand (car r)
-                                              'module
-                                              (syntax->list
-                                               (quote-syntax 
-                                                (quote 
-                                                 quote-syntax #%top
-                                                 lambda case-lambda
-                                                 let-values letrec-values
-                                                 begin begin0 set!
-                                                 with-continuation-mark
-                                                 if #%app #%expression
-                                                 define-values define-syntaxes begin-for-syntax
-                                                 module module*
-                                                 #%module-begin 
-                                                 #%require #%provide #%declare
-                                                 #%variable-reference))))])
-                ;; `begin' is special...
-                (if (let-values ([(p) (syntax-e e)])
-                      (if (pair? p)
-                          (if (symbol? (syntax-e (car p)))
-                              (if (free-identifier=? (car p) (quote-syntax begin))
-                                  (syntax->list e)
-                                  #f)
-                              #f)
-                          #f))
-                    ;; splice `begin'
-                    (let-values ([(l) (syntax->list e)])
-                      (datum->syntax
-                       stx
-                       (cons (car l)
-                             (append
-                              (map (lambda (elem)
-                                     (list
-                                      (quote-syntax printing-module-begin)
-                                      (syntax-track-origin elem e (car l))))
-                                   (cdr l))
-                              (cdr r)))
-                       stx))
-                    ;; no need to splice
-                    (let-values ([(wrap?)
-                                  (let-values ([(e) (syntax-e e)])
-                                    (if (pair? e)
-                                        (let-values ([(a) (car e)])
-                                          (if (symbol? (syntax-e a))
-                                              (if (ormap (lambda (i)
-                                                           (free-identifier=? i a))
-                                                         (syntax->list
-                                                          (quote-syntax 
-                                                           (define-values define-syntaxes begin-for-syntax
-                                                             module module*
-                                                             #%module-begin 
-                                                             #%require #%provide #%declare))))
-                                                  #f
-                                                  ;; Also check for calls to `void':
-                                                  (if (free-identifier=? a (quote-syntax #%app))
-                                                      (let-values ([(e) (cdr e)])
-                                                        (let-values ([(e) (if (syntax? e)
-                                                                              (syntax-e e)
-                                                                              e)])
-                                                          (if (pair? e)
-                                                              (if (symbol? (syntax-e (car e)))
-                                                                  (if (free-identifier=? (car e) (quote-syntax void))
-                                                                      #f
-                                                                      #t)
-                                                                  #t)
-                                                              #t)))
-                                                      #t))
-                                              #t))
-                                        #t))])
-                      (let-values ([(e) (if wrap?
-                                            (datum->syntax
-                                             (quote-syntax here)
-                                             (list (quote-syntax #%app)
-                                                   (quote-syntax call-with-values)
-                                                   (list (quote-syntax lambda)
-                                                         '()
-                                                         e)
-                                                   (quote-syntax print-values))
-                                             e)
-                                            e)])
-                        (datum->syntax
-                         stx
-                         (if (null? (cdr r))
-                             (list (quote-syntax begin) e)
-                             (list (quote-syntax begin)
-                                   e
-                                   (cons (quote-syntax printing-module-begin)
-                                         (cdr r))))
-                         stx)))))))))))
+      (let-values ([(e) (cadr (syntax->list stx))])
+        (datum->syntax
+         (quote-syntax here)
+         (list (quote-syntax #%app)
+               (quote-syntax call-with-values)
+               (list (quote-syntax lambda)
+                     '()
+                     e)
+               (quote-syntax print-values))
+         e)))))
diff --git a/racket/collects/syntax/wrap-modbeg.rkt b/racket/collects/syntax/wrap-modbeg.rkt
new file mode 100644
index 0000000000..531984db50
--- /dev/null
+++ b/racket/collects/syntax/wrap-modbeg.rkt
@@ -0,0 +1,144 @@
+;; A #%module-begin that wraps each module-level expression with 
+;;  given form:
+
+(module modbeg '#%kernel
+  (#%require (for-syntax '#%kernel))
+
+  (#%provide (for-syntax make-wrapping-module-begin))
+
+  (begin-for-syntax
+   (define-values (make-wrapping-module-begin)
+     (case-lambda 
+      [(wrapper) (make-wrapping-module-begin wrapper (quote-syntax #%module-begin))]
+      [(wrapper module-begin)
+       (lambda (stx)
+         (if (eq? 'module-begin (syntax-local-context))
+             (void)
+             (raise-syntax-error
+              #f
+              "allowed only around a module body"
+              stx))
+         (if (symbol? (syntax-e stx))
+             (raise-syntax-error
+              #f
+              "bad syntax" 
+              stx)
+             (void))
+         (let-values ([(l) (syntax->list stx)])
+           (if l
+               (void)
+               (raise-syntax-error
+                #f
+                "bad syntax (illegal use of `.')" 
+                stx))
+           (datum->syntax
+            stx
+            (cons module-begin
+                  (map (lambda (e)
+                         (list (quote-syntax do-wrapping-module-begin)
+                               wrapper
+                               e))
+                       (cdr l)))
+            stx
+            stx)))])))
+
+  (define-syntaxes (do-wrapping-module-begin)
+    (lambda (stx)
+      (let-values ([(r) (cdr (syntax-e stx))])
+        (let-values ([(r) (if (syntax? r)
+                              (syntax-e r)
+                              r)])
+          (let-values ([(wrapper) (car r)]
+                       [(r) (cdr r)])
+            (let-values ([(r) (if (syntax? r)
+                                  (syntax-e r)
+                                  r)])
+              (if (null? r)
+                  (quote-syntax (void))
+                  (let-values ([(e) (local-expand (car r)
+                                                  'module
+                                                  (syntax->list
+                                                   (quote-syntax 
+                                                    (quote 
+                                                     quote-syntax #%top
+                                                     lambda case-lambda
+                                                     let-values letrec-values
+                                                     begin begin0 set!
+                                                     with-continuation-mark
+                                                     if #%app #%expression
+                                                     define-values define-syntaxes begin-for-syntax
+                                                     module module*
+                                                     #%module-begin 
+                                                     #%require #%provide #%declare
+                                                     #%variable-reference))))])
+                    ;; `begin' is special...
+                    (if (let-values ([(p) (syntax-e e)])
+                          (if (pair? p)
+                              (if (symbol? (syntax-e (car p)))
+                                  (if (free-identifier=? (car p) (quote-syntax begin))
+                                      (syntax->list e)
+                                      #f)
+                                  #f)
+                              #f))
+                        ;; splice `begin'
+                        (let-values ([(l) (syntax->list e)])
+                          (datum->syntax
+                           stx
+                           (cons (car l)
+                                 (append
+                                  (map (lambda (elem)
+                                         (list
+                                          (quote-syntax do-wrapping-module-begin)
+                                          wrapper
+                                          (syntax-track-origin elem e (car l))))
+                                       (cdr l))
+                                  (cdr r)))
+                           stx))
+                        ;; no need to splice
+                        (let-values ([(wrap?)
+                                      (let-values ([(e) (syntax-e e)])
+                                        (if (pair? e)
+                                            (let-values ([(a) (car e)])
+                                              (if (symbol? (syntax-e a))
+                                                  (if (ormap (lambda (i)
+                                                               (free-identifier=? i a))
+                                                             (syntax->list
+                                                              (quote-syntax 
+                                                               (define-values define-syntaxes begin-for-syntax
+                                                                 module module*
+                                                                 #%module-begin 
+                                                                 #%require #%provide #%declare))))
+                                                      #f
+                                                      ;; Also check for calls to `void':
+                                                      (if (free-identifier=? a (quote-syntax #%app))
+                                                          (let-values ([(e) (cdr e)])
+                                                            (let-values ([(e) (if (syntax? e)
+                                                                                  (syntax-e e)
+                                                                                  e)])
+                                                              (if (pair? e)
+                                                                  (if (symbol? (syntax-e (car e)))
+                                                                      (if (free-identifier=? (car e) (quote-syntax void))
+                                                                          #f
+                                                                          #t)
+                                                                      #t)
+                                                                  #t)))
+                                                          #t))
+                                                  #t))
+                                            #t))])
+                          (let-values ([(e) (if wrap?
+                                                (datum->syntax
+                                                 (quote-syntax here)
+                                                 (list wrapper
+                                                       e)
+                                                 e)
+                                                e)])
+                            (datum->syntax
+                             stx
+                             (if (null? (cdr r))
+                                 (list (quote-syntax begin) e)
+                                 (list (quote-syntax begin)
+                                       e
+                                       (list* (quote-syntax do-wrapping-module-begin)
+                                              wrapper
+                                              (cdr r))))
+                             stx)))))))))))))