resolve provide-specs in pre-transformer, broken for all-from-out

racket-namespace.rkt

#lang racket/base

(provide define-namespace
         with-namespace
         namespace-out
         namespace-in)

;; (define-namespace _namespace-name)

;; (with-namespace _namespace-name _body)

;; (provide (namespace-out _namespace-name _provide-spec ...))

;; (require (namespace-in _namespace-name _module-path))

(require syntax/parse/define
         (for-syntax racket/base
                     racket/match
                     racket/syntax
                     racket/provide-transform
                     racket/require-transform
                     syntax/parse/class/local-value))

(begin-for-syntax
  (struct namespace-info [scope submod-name])

  (define-syntax-class namespace-id
    [pattern (~var id (local-value namespace-info?))
      #:attr scope
      (namespace-info-scope (attribute id.local-value))
      #:attr submod-name
      (namespace-info-submod-name (attribute id.local-value))])

  ;; syntax-replace-context/shallow : Syntax Syntax -> Syntax
  (define (syntax-replace-context/shallow ctx stx)
    (datum->syntax ctx (syntax-e stx) stx stx))

  ;; add-submod : [Syntaxof ModulePath] Identifier -> [Syntaxof ModulePath]
  (define (add-submod mp submod-name)
    (syntax-replace-context/shallow
     mp
     (syntax-parse mp
       #:literals [submod]
       [(submod fp s ...)
        #`(submod fp s ... #,submod-name)]
       [fp
        #`(submod fp #,submod-name)])))

  ;; export->provide-spec : Export -> ProvideSpecSyntax
  (define (export->provide-spec e)
    (match-define (export local-id out-sym mode protect? orig-stx) e)
    (if protect?
        #`(for-meta #,mode (protect-out (rename-out [#,local-id #,out-sym])))
        #`(for-meta #,mode (rename-out [#,local-id #,out-sym])))))

(define-syntax-parser define-namespace
  [(_ ns:id)
   #:with submod-name (generate-temporary #'ns)
   #'(define-syntax ns
       (namespace-info (make-syntax-introducer)
                       (quote-syntax submod-name)))])

(define-syntax-parser with-namespace
  [(_ ns:namespace-id body:expr)
   ((attribute ns.scope)
    #'body)])

(define-syntax namespace-out
  (make-provide-pre-transformer
   (lambda (stx modes)
     (syntax-parse stx
       [(_ ns:namespace-id provide-spec:expr ...)
        #:with [provide-spec* ...] ((attribute ns.scope) #'[provide-spec ...])
        #:with [[export* ...] ...]
        (for/list ([prov* (in-list (syntax->list #'[provide-spec* ...]))])
          (map export->provide-spec (expand-export prov* modes)))
        (syntax-local-lift-module-end-declaration
         #'(module+ ns.submod-name
             (provide export* ... ...)))
        #'(combine-out)]))))

(define-syntax namespace-in
  (make-require-transformer
   (syntax-parser
     [(_ ns:namespace-id module-path:expr)
      #:do [(define-values [imports sources]
              (expand-import (add-submod #'module-path #'ns.submod-name)))
            (define imports*
              (for/list ([i (in-list imports)])
                (struct-copy import i
                  [local-id ((attribute ns.scope) (import-local-id i))])))]
      (values imports*
              sources)])))