#lang scheme/base
(require (planet bzlib/base)
         "resolve.ss" 
         (for-template scheme/base) 
         syntax/stx
         )

;; okay - so the literal are not binding in a pure function... which makes
;; separation of syntax functions from transformation environment a bit useless...
;; not sure if this is an intended behavior or not...

(define (require-unify stx)
  (define (resolve spec) 
    (syntax-case spec (only-in 
                       except-in 
                       prefix-in
                       rename-in
                       combine-in
                       only-meta-in
                       for-syntax 
                       for-template 
                       for-label 
                       for-meta 
                       lib 
                       planet 
                       file 
                       ) 
      ((only-in inner in ...) 
       #`(only-in #,(resolve #'inner) in ...))
      ((except-in inner in ...) 
       #`(except-in #,(resolve #'inner) in ...))
      ((prefix-in prefix inner) 
       #`(prefix-in prefix #,(resolve #'inner)))
      ((rename-in inner in ...) 
       #`(rename-in #,(resolve #'inner) in ...))
      ((combine-in inner ...) 
       #`(combine-in #,@(syntax-map resolve #'(inner ...))))
      ((only-meta-in phase inner ...) 
       #`(only-meta-in phase #,@(syntax-map resolve #'(inner ...))))
      ((for-syntax inner ...) 
       #`(for-syntax #,@(syntax-map resolve #'(inner ...))))
      ((for-template inner ...) 
       #`(for-template #,@(syntax-map resolve #'(inner ...))))
      ((for-label inner ...) 
       #`(for-label #,@(syntax-map resolve #'(inner ...))))
      ((for-meta phase inner ...) 
       #`(for-meta phase #,@(syntax-map resolve #'(inner ...))))
      ((lib str ...) 
       (raise-syntax-error 'require "lib is deprecated." #'(lib str ...)))
      ((file str)
       (raise-syntax-error 'require "file is deprecated." #'(file str))) 
      ((planet spec ...) 
       (raise-syntax-error 'require "planet is deprecated." #'(planet spec ...)))
      (mod-path 
       (resolve-module-path (syntax->datum #'mod-path))
       #'mod-path)
      (mod-path 
       (datum->syntax stx 
                      (list (datum->syntax stx 'planet) #'mod-path)))))
  (syntax-case stx ()
    ((~ spec ...) 
     (datum->syntax stx (cons (datum->syntax stx 'require)
                              (syntax-map resolve #'(spec ...)))))
    ))

(define (provide-unify stx) 
  (define (resolve-path path) 
    (syntax-case path () 
      (path
       (resolve-module-path (syntax->datum #'path))
       #'path)
      (path 
       (datum->syntax stx 
                      (list (datum->syntax stx 'planet) #'path)))))
  (define (resolve spec)
    (syntax-case spec (all-defined-out
                       all-from-out
                       rename-out 
                       except-out 
                       prefix-out 
                       struct-out 
                       combine-out 
                       protect-out 
                       for-meta
                       for-syntax 
                       for-template 
                       for-label 
                       ) 
      ((all-defined-out)
       #'(all-defined-out))
      ((all-from-out inner ...) 
       #`(all-from-out #,@(syntax-map resolve-path #'(inner ...))))
      ((rename-out id ...) 
       #`(rename-out id ...)) 
      ((except-out inner ...) 
       #`(except-out #,@(syntax-map resolve #'(inner ...))))
      ((prefix-out prefix inner) 
       #`(prefix-out prefix #,(resolve #'inner))) 
      ((struct-out id) 
       #'(struct-out id)) 
      ((combine-out inner ...) 
       #`(combine-out #,@(syntax-map resolve #'(inner ...)))) 
      ((protect-out inner ...) 
       #`(protect-out #,@(syntax-map resolve #'(inner ...))))
      ((for-meta phase inner ...) 
       #`(for-meta phase #,@(syntax-map resolve #'(inner ...))))
      ((for-syntax inner ...) 
       #`(for-syntax #,@(syntax-map resolve #'(inner ...))))
      ((for-template inner ...) 
       #`(for-template #,@(syntax-map resolve #'(inner ...))))
      ((for-label phase inner ...) 
       #`(for-label #,@(syntax-map resolve #'(inner ...))))
      (id 
       (symbol? (syntax->datum #'id))
       #'id)
      (err
       (raise-syntax-error 'provide "invalid provide-spec: ~s" (syntax->datum #'err)))
      ))
  ;; (trace resolve)
  (syntax-case stx () 
    ((~ spec ...) 
     (datum->syntax stx (cons (datum->syntax stx 'provide)
                              (syntax-map resolve #'(spec ...)))))
    )) 

(define (require->require/unify stx)
  (datum->syntax stx (cons (datum->syntax stx 'require/unify) 
                           (stx-cdr stx))))
;; (trace require->require/unify)

(define (provide->provide/unify stx) 
  (datum->syntax stx (cons (datum->syntax stx 'provide/unify) 
                           (stx-cdr stx))))

(provide require-unify provide-unify
         require->require/unify 
         provide->provide/unify 
         )