#lang scheme

(require "planet.ss"
         (cce define)
         (for-syntax scheme/match
                     (cce syntax)))

(provide begin-below rename-below)

;; active-below-scopes : (Box (Listof Scope))
;; A Scope is a (Box (Listof Def))
;; A Def is a (Box Boolean)
(define-for-syntax active-below-scopes (box null))

(define-syntax (begin-below stx)
  (syntax-case stx ()
    [(_ term ...)
     (match (syntax-local-context)
       ['expression
        (raise-syntax-error 'begin-below
                            "cannot be used as an expression"
                            stx)]
       [(or 'top-level 'module-begin 'module (? pair?))
        (syntax/loc stx
          (begin
            (define-syntax below-scope (box null))
            (in-phase1
             (set-box! active-below-scopes
                       (cons (syntax-local-value #'below-scope)
                             (unbox active-below-scopes))))
            term
            ...
            (in-phase1
             (let ([scope (syntax-local-value #'below-scope)])
               (set-box! active-below-scopes
                         (remq scope (unbox active-below-scopes)))
               (for ([def (in-list (unbox scope))])
                 (set-box! def #f))))))])]))

(define-syntax (rename-below stx)
  (syntax-case stx ()
    [(_ [above below] ...)
     (begin
       (for/first ([id (in-list (syntax-list above ... below ...))]
                   #:when (not (identifier? id)))
         (raise-syntax-error #f "expected an identifier" stx id))
       (match (syntax-local-context)
         ['expression
          (raise-syntax-error #f "cannot be used as an expression" stx)]
         ['top-level
          (syntax/loc stx
            (define-syntaxes [below ...]
              (values (redirect-transformer #'above) ...)))]
         [_
          (with-syntax ([orig stx])
            (syntax/loc stx
              (begin
                (define-syntax below? (box #t))
                (in-phase1
                 (begin
                   (unless (pair? (unbox active-below-scopes))
                     (raise-syntax-error #f
                       "used outside of begin-below" #'orig))
                   (let* ([def (syntax-local-value #'below?)]
                          [scope (car (unbox active-below-scopes))])
                     (set-box! scope (cons def (unbox scope))))))
                (in-phase1/pass2
                 (set-box! (syntax-local-value #'below?) #t))
                (define-syntaxes [below ...]
                  (values
                   (lambda (stx*)
                     (unless (unbox (syntax-local-value #'below?))
                       (raise-syntax-error (syntax-e #'below)
                         "used before definition"
                         stx*))
                     ((redirect-transformer #'above) stx*))
                   ...)))))]))]))