#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
                            "can not 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))
       (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*))
                ...))))))]))