racket/collects/web-server/lang/util.ss

#lang scheme/base
(require (for-template scheme/base)
         (lib "kerncase.ss" "syntax")
         (lib "pretty.ss")
         (lib "list.ss"))
(provide (except-out (all-defined-out) template))

(define transformer? (make-parameter #f))

(define (recertify old-expr expr)
  (syntax-recertify expr old-expr (current-code-inspector) #f))

(define (recertify* old-expr exprs)
  (map (lambda (expr)
         (syntax-recertify expr old-expr (current-code-inspector) #f))
       exprs))

(define (recertify/new-defs old-expr thunk)
  (call-with-values
   thunk
   (lambda (expr new-defs)
     (values (recertify old-expr expr)
             (recertify* old-expr new-defs)))))

(define current-code-labeling
  (make-parameter
   (lambda (stx)
     (datum->syntax stx 'error))))

(define (generate-formal sym-name)
  (let ([name (datum->syntax #f (gensym sym-name))])
    (with-syntax ([(lambda (formal) ref-to-formal)
                   (if (syntax-transforming?)
                       (local-expand #`(lambda (#,name) #,name) 'expression empty)
                       #`(lambda (#,name) #,name))])
      (values #'formal #'ref-to-formal))))

(define (formals-list stx)
  (syntax-case stx ()
    [v (identifier? #'v)
       (list #'v)]
    [(v ...)
     (syntax->list #'(v ...))]
    [(v ... . rv)
     (list* #'rv (syntax->list #'(v ...)))]))

(define ((make-define-case/new-defs inner) stx)
  (recertify*
   stx
   (syntax-case stx (define-values define-syntaxes define-values-for-syntax)
     [(define-values (v ...) ve)
      (let-values ([(nve defs) (inner #'ve)])
        (append 
         defs
         (list (quasisyntax/loc stx
                 (define-values (v ...) #,nve)))))]
     [(define-syntaxes (v ...) ve)
      (parameterize ([transformer? #t])
        (let-values ([(nve defs) (inner #'ve)])
          (append 
           defs
           (list (quasisyntax/loc stx
                   (define-syntaxes (v ...) #,nve))))))]      
     [(define-values-for-syntax (v ...) ve)
      (parameterize ([transformer? #t])
        (let-values ([(nve defs) (inner #'ve)])
          (append 
           defs
           (list (quasisyntax/loc stx
                   (define-values-for-syntax (v ...) #,nve))))))]
     [(#%require spec ...)
      (list stx)]
     [expr
      (let-values ([(nexpr defs) (inner #'expr)])
        (append defs (list nexpr)))])))

(define ((make-module-case/new-defs inner) stx)
  (recertify*
   stx
   (syntax-case* stx (#%provide) free-identifier=?     
     [(#%provide spec ...)
      (list stx)]
     [_
      (inner stx)])))

(define ((make-lang-module-begin make-labeling transform) stx)
  (recertify
   stx
   (syntax-case stx ()
     [(mb forms ...)
      (with-syntax ([(pmb body ...)
                     (local-expand (quasisyntax/loc stx
                                     (#%module-begin forms ...))
                                   'module-begin 
                                   empty)])
        (define base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx)))))      
        (define new-defs 
          (parameterize ([current-code-labeling
                          (lambda (stx) (datum->syntax stx (base-labeling)))])
            (apply append (map transform (syntax->list #'(body ...))))))
        #;(pretty-print (syntax->datum #`(pmb #,@new-defs)))
        (quasisyntax/loc stx
          (pmb #,@new-defs)))])))

(define (bound-identifier-member? id ids)
  (ormap
   (lambda (an-id)
     (bound-identifier=? id an-id))
   ids))

;; Kernel Case Template
(define (template stx)  
  (recertify
   stx
   (kernel-syntax-case 
       stx (transformer?)
     [(begin be ...)
      (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
        (syntax/loc stx
          (begin be ...)))]
     [(begin0 be ...)
      (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
        (syntax/loc stx
          (begin0 be ...)))]
     [(set! v ve)
      (with-syntax ([ve (template #'ve)])
        (syntax/loc stx
          (set! v ve)))]
     [(let-values ([(v ...) ve] ...) be ...)
      (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
                    [(be ...) (map template (syntax->list #'(be ...)))])
        (syntax/loc stx
          (let-values ([(v ...) ve] ...) be ...)))]
     [(letrec-values ([(v ...) ve] ...) be ...)
      (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
                    [(be ...) (map template (syntax->list #'(be ...)))])
        (syntax/loc stx
          (letrec-values ([(v ...) ve] ...) be ...)))]
     [(#%plain-lambda formals be ...)
      (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
        (syntax/loc stx
          (#%plain-lambda formals be ...)))]
     [(case-lambda [formals be ...] ...)
      (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))])
        (syntax/loc stx
          (case-lambda [formals be ...] ...)))]
     [(if te ce ae)
      (with-syntax ([te (template #'te)]
                    [ce (template #'ce)]
                    [ae (template #'ae)])
        (syntax/loc stx
          (if te ce ae)))]
     [(quote datum)
      stx]
     [(quote-syntax datum)
      stx]     
     [(with-continuation-mark ke me be)
      (with-syntax ([ke (template #'ke)]
                    [me (template #'me)]
                    [be (template #'be)])
        (syntax/loc stx
          (with-continuation-mark ke me be)))]
     [(#%plain-app e ...)
      (with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
        (syntax/loc stx
          (#%plain-app e ...)))]
     [(#%top . v)
      stx]
     [(#%variable-reference . v)
      stx]       
     [id (identifier? #'id)
         stx]     
     [_
      (raise-syntax-error 'kerncase "Dropped through:" stx)])))