scoped-quotation.rkt

#lang racket

(require (for-syntax (for-syntax (only-in racket/private/sc
                                          [syntax-mapping-depth syntax-pattern-variable-depth]
                                          [syntax-mapping-valvar syntax-pattern-variable-value]))
                     (rename-in racket [quote-syntax quote-syntax/no-introduce])
                     syntax/parse/define)
         syntax/parse/define)

(begin-for-syntax
  (define ((make-unscoped-transformer proc) stx)
    (syntax-local-introduce (proc (syntax-local-introduce stx))))

  (define current-syntax-introducer (make-parameter #f))
  (define (current-syntax-introduce stx)
    ((or (current-syntax-introducer) (make-syntax-introducer)) stx))
  (define (call-with-shared-syntax-introducer proc)
    (if (current-syntax-introducer)
        (proc)
        (parameterize ([current-syntax-introducer (make-syntax-introducer)])
          (proc))))
  (define (call-with-masked-syntax-introducer proc)
    (parameterize ([current-syntax-introducer #f])
      (proc)))
  (define-simple-macro (with-shared-syntax-introducer body:expr ...+)
    (call-with-shared-syntax-introducer (λ () body ...)))
  (define-simple-macro (with-masked-syntax-introducer body:expr ...+)
    (call-with-masked-syntax-introducer (λ () body ...)))

  (define-simple-macro (quote-syntax form)
    (current-syntax-introduce (quote-syntax/no-introduce form)))

  (begin-for-syntax
    (define-syntax-class pattern-variable
      #:attributes [depth value]
      #:description "pattern variable"
      #:opaque
      [pattern x:id
               #:do [(define local-value (syntax-local-value #'x (λ () #f)))]
               #:when (syntax-pattern-variable? local-value)
               #:attr depth (syntax-pattern-variable-depth local-value)
               #:attr value (syntax-pattern-variable-value local-value)])

    (define-syntax-class (syntax-template quasi?)
      #:attributes [expr]
      #:description "template"
      #:commit
      [pattern x:pattern-variable
               #:and ~!
               #:fail-unless (zero? (attribute x.depth))
                             "ellipsis depths greater than zero are not supported"
               #:attr expr (syntax-property #'x.value 'disappeared-use (syntax-local-introduce #'x))]
      [pattern {~and {~fail #:unless quasi?}
                     ({~literal unsyntax} ~! x:expr)}
               #:attr expr #'(with-masked-syntax-introducer x)]
      [pattern (x* ...)
               #:and ~!
               #:with [{~var x (syntax-template quasi?)} ...] #'[x* ...]
               #:attr expr #`(datum->syntax (quote-syntax #,this-syntax)
                                            (list x.expr ...)
                                            (quote-syntax/no-introduce #,this-syntax)
                                            (quote-syntax/no-introduce #,this-syntax))]
      [pattern (x* ...+ . y*)
               #:and ~!
               #:with [{~var x (syntax-template quasi?)} ...] #'[x* ...]
               #:with {~var y (syntax-template quasi?)} #'y*
               #:attr expr #`(datum->syntax (quote-syntax #,this-syntax)
                                            (list* x.expr ... y.expr)
                                            (quote-syntax/no-introduce #,this-syntax)
                                            (quote-syntax/no-introduce #,this-syntax))]
      [pattern x:expr
               #:attr expr #'(quote-syntax x)]))

  (define-syntax-parser syntax
    [(_ {~var template (syntax-template #f)})
     #'(with-shared-syntax-introducer template.expr)])
  (define-syntax-parser quasisyntax
    [(_ {~var template (syntax-template #t)})
     #'(with-shared-syntax-introducer template.expr)]))