#lang scheme

(require (lib "unit.ss")
         ;;(lib "etc.ss")
         "rename-below.ss"
         "../private/planet.ss")

(require (for-syntax (lib "unit-exptime.ss")
                     (lib "function.ss" "scheme")
                     (cce values)
                     (cce function)
                     (cce syntax)))

(provide top/error rename-below
         import export
         define-values-below define-below
         define-values/invoke-unit/below)

(define-syntax (top/error stx)
  (syntax-case stx ()
    [(t/e . id)
     (identifier? #'id)
     (raise-syntax-error #f "undefined" #'id)]))

(define-syntax (define-values/invoke-unit/below stx)
  (syntax-case stx ( import export )
    [(d/i/b u@ (import i^ ...) (export e^ ...))
     (let*-values ([(exports) (syntax->list (syntax (e^ ...)))]
                   [(parents var-lists def-lists stx-lists)
                    (map/values 4
                                (papplyr signature-members stx)
                                exports)])
       (with-syntax* ([((e^-orig ...) ...)
                       (map append var-lists def-lists stx-lists)]
                      [((e^-name ...) ...)
                       (map (lambda (names)
                              (map (lambda (id)
                                     (syntax-local-introduce
                                      (syntax-local-get-shadower id)))
                                   (syntax->list names)))
                            (syntax->list (syntax ((e^-orig ...) ...))))]
                      [((e^-below ...) ...)
                       (map generate-temporaries
                            (syntax->list #'((e^-name ...) ...)))])
         (syntax/loc stx
           (begin
             (define-values/invoke-unit
               u@
               (import i^ ...)
               (export (rename e^ [e^-below e^-name] ...) ...))
             (rename-below [e^-below e^-name] ... ...)))))]))

(define-syntax (define-below stx)
  (syntax-case stx ()
    [(d-b (header . formals) . body)
     (syntax/loc stx (d-b header (lambda formals . body)))]
    [(d-b var body)
     (syntax/loc stx
       (define-values-below (var) body))]))

(define-syntax (define-values-below stx)
  (syntax-case stx ()
    [(d-v-b (var ...) body)
     (with-syntax ([(below ...) (generate-temporaries #'(var ...))])
       (syntax/loc stx
         (begin
           (rename-below [below var] ...)
           (define-values (below ...) body))))]))