#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 (#%as-definition/name stx0)
  (syntax-case stx0 ()
    [(_ name form)
     (match (syntax-local-context)
       ['expression
        (raise-syntax-error (syntax-e #'name)
                            "may not be used as an expression"
                            stx0)]
       [(or 'top-level 'module 'module-begin)
        #'form]
       [(? pair?)
        (let* ([stx (head-expand #'form)])
          (syntax-case stx ( module
                             #%require
                             #%provide
                             define-values
                             define-syntaxes
                             define-values-for-syntax
                             begin )
            [(module . _) stx]
            [(#%require . _) stx]
            [(#%provide . _) stx]
            [(define-values . _) stx]
            [(define-syntaxes . _) stx]
            [(define-values-for-syntax . _) stx]
            [(begin d ...)
             (syntax/loc stx0 (begin (#%as-definition/name name d) ...))]
            [e
             (syntax/loc stx0
               (define-values [] (begin e (#%plain-app values))))]))])]))

(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))))
            (#%as-definition/name begin-below 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*))
                ...))))))]))