expander: allow syntax-local-lift-require during #%module-begin expansion

Making `syntax-local-lift-require` during `#%module-begin` expansion
provides a solution to a long-standing problem with composing
languages via `#%module-begin`, where the bindings of some lanuage
should be made available for expanding the module body by
`#%module-begin` expansion (i.e., the language is *not* the initial
import). If the language does not support `require`, then there was no
way to expand and expose the language import dependency.

Closes #1352

pkgs/racket-test-core/tests/racket/macro.rktl

@@ -1075,9 +1075,7 @@
 
 (for ([lift-attempt+rx:expected-error
        (in-list
-        (list (cons '(syntax-local-lift-require 'racket #'body)
-                    #rx"could not find target context")
-              (cons '(syntax-local-lift-expression #'body)
+        (list (cons '(syntax-local-lift-expression #'body)
                     #rx"no lift target")
               (cons '(syntax-local-lift-module  #'(module m racket/base))
                     #rx"not currently transforming within a module declaration or top level")

pkgs/racket-test-core/tests/racket/module.rktl

@@ -2703,6 +2703,61 @@ case of module-leve bindings; it doesn't cover local bindings.
 
   (dynamic-require '(submod 'm-use main) #f))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that syntax-local-lift-require works in `#%module-begin` expansion
+
+(module adds-racket-promise-but-without-reachable-bindings racket/base
+  (require (for-syntax racket/base))
+  
+  (provide (except-out (all-from-out racket/base)
+                       #%module-begin)
+           (rename-out [module-begin #%module-begin]))
+  
+  (define-syntax (module-begin stx)
+    (syntax-case stx ()
+      [(_ . body)
+       (syntax-local-lift-require 'racket/promise #'body)
+       #'(#%module-begin . body)])))
+
+(test '(module m 'adds-racket-promise-but-without-reachable-bindings
+         (#%module-begin
+          (#%require racket/promise)
+          (module configure-runtime '#%kernel
+            (#%module-begin
+             (#%require racket/runtime-config)
+             (#%app configure '#f)))))
+      syntax->datum
+      (expand '(module m 'adds-racket-promise-but-without-reachable-bindings)))
+
+(err/rt-test/once (expand '(module m 'adds-racket-promise-but-without-reachable-bindings
+                             force))
+                  exn:fail:syntax?)
+
+(module adds-racket-promise-with-reachable-bindings racket/base
+  (require (for-syntax racket/base))
+  
+  (provide (except-out (all-from-out racket/base)
+                       #%module-begin)
+           (rename-out [module-begin #%module-begin]))
+  
+  (define-syntax (module-begin stx)
+    (syntax-case stx ()
+      [(_ . body)
+       (with-syntax ([body (syntax-local-lift-require 'racket/promise #'body)])
+         #'(#%module-begin . body))])))
+
+(test '(module m 'adds-racket-promise-with-reachable-bindings
+         (#%module-begin
+          (#%require racket/promise)
+          (module configure-runtime '#%kernel
+            (#%module-begin
+             (#%require racket/runtime-config)
+             (#%app configure '#f)))
+          (#%app call-with-values (lambda () force) print-values)))
+      syntax->datum
+      (expand '(module m 'adds-racket-promise-with-reachable-bindings
+                 force)))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Make sure that a module can be attached without a recorded namespace syntax context
 

racket/src/expander/expand/lift-context.rkt

@@ -30,6 +30,7 @@
          
          make-require-lift-context
          add-lifted-require!
+         get-require-lifts
          get-and-clear-require-lifts!
          require-lift-context-wrt-phase
          
@@ -182,8 +183,11 @@
                               requires)   ; records lifted requires
   #:authentic)
 
-(define (make-require-lift-context wrt-phase do-require)
-  (require-lift-context do-require wrt-phase (box null)))
+(define (make-require-lift-context wrt-phase do-require [initial-lifts null])
+  (require-lift-context do-require wrt-phase (box initial-lifts)))
+
+(define (get-require-lifts require-lifts)
+  (unbox (require-lift-context-requires require-lifts)))
 
 (define (get-and-clear-require-lifts! require-lifts)
   (box-clear! (require-lift-context-requires require-lifts)))

racket/src/expander/expand/module.rkt

@@ -282,6 +282,9 @@
      
      ;; Accumulated declared submodule names for `syntax-local-submodules`
      (define declared-submodule-names (make-hasheq))
+
+     ;; Requires that were lifted during `#%module-begin` expansion:
+     (define initial-lifted-requires (get-require-lifts (expand-context-require-lifts ctx)))
      
      ;; Module expansion always parses the module body along the way,
      ;; even if `to-parsed?` in `ctx` is not true. The body is parsed
@@ -298,7 +301,8 @@
      
      ;; Passes 1 and 2 are nested via `begin-for-syntax`:
      (define expression-expanded-bodys
-       (let pass-1-and-2-loop ([bodys bodys] [phase phase] [keep-stops? (stop-at-module*? ctx)])
+       (let pass-1-and-2-loop ([bodys bodys] [phase phase] [keep-stops? (stop-at-module*? ctx)]
+                                             [initial-lifted-requires initial-lifted-requires])
 
          ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
          ;; Pass 1: partially expand to discover all bindings and install all 
@@ -325,7 +329,8 @@
                                                 [require-lifts (make-require-lift-context
                                                                 phase
                                                                 (make-parse-lifted-require m-ns self requires+provides
-                                                                                           #:declared-submodule-names declared-submodule-names))]
+                                                                                           #:declared-submodule-names declared-submodule-names)
+                                                                initial-lifted-requires)]
                                                 [to-module-lifts (make-to-module-lift-context
                                                                   phase
                                                                   #:shared-module-ends module-ends
@@ -481,7 +486,10 @@
                    [lifts #f]
                    [module-lifts #f]
                    [to-module-lifts #f]
-                   [require-lifts #f]))
+                   [require-lifts (make-require-lift-context
+                                   phase
+                                   (make-parse-lifted-require m-ns self requires+provides
+                                                              #:declared-submodule-names (make-hasheq)))]))
    
    (define mb-scopes-s
      (if keep-enclosing-scope-at-phase
@@ -773,7 +781,7 @@
           (define ct-m-ns (namespace->namespace-at-phase m-ns (add1 phase)))
           (prepare-next-phase-namespace partial-body-ctx)
           (log-expand partial-body-ctx 'phase-up)
-          (define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase) #f))
+          (define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase) #f null))
           (log-expand partial-body-ctx 'next-group)
           (namespace-run-available-modules! m-ns (add1 phase)) ; to support running `begin-for-syntax`
           (eval-nested-bodys nested-bodys (add1 phase) ct-m-ns self partial-body-ctx)