#lang scheme/base

;; Abstract the global name space mechanism.

(require
 "rep.ss"
 "../tools.ss"
 "ns-tx.ss"      ;; for reflection
 scheme/shared
 (for-syntax
  scheme/base
  syntax/stx
  "ns-tx.ss"
  ))

(provide
 (all-defined-out))

(define-for-syntax (tx _tx id stx)
  (_tx #`(#,id #,@(stx-cdr stx))))

(define-syntax (define-ns stx)         (tx define-ns-tx #'define stx))
(define-syntax (define-syntax-ns stx)  (tx define-ns-tx #'define-syntax stx))
(define-syntax (redefine!-ns stx)      (tx redefine!-ns-tx #'define stx))

(define-syntax (definitions-ns stx)    (tx definitions-ns-tx #'define-ns stx))
(define-syntax (redefinitions!-ns stx) (tx definitions-ns-tx #'redefine!-ns stx))

(define-syntax (let-ns stx)    (let-ns-tx #`(let    #,@(stx-cdr stx))))
(define-syntax (letrec-ns stx) (let-ns-tx #`(letrec #,@(stx-cdr stx))))
(define-syntax (shared-ns stx) (let-ns-tx #`(shared #,@(stx-cdr stx))))

(define-sr (tx->syntax-ns ns (name tx) ...)
  (begin (define-syntax-ns ns name tx) ...))
    
(define-syntax (ns stx)
  (syntax-case stx ()
    ((_ ns name)
     (ns-prefixed #'ns #'name))))


;; Parameterize word semantics. Auto-upgrade plain word instances to
;; parameter word instances.
(define-syntax (parameterize-words-ns! stx)
  (parameterize-words-ns-tx
   #`(word-parameter! #,@(stx-cdr stx))))

;; This version only parameterizes words that are already defined as a
;; parameter word.
(define-syntax (parameterize-words-ns stx)
  (parameterize-words-ns-tx
   #`(word-parameter #,@(stx-cdr stx))))

;; Same as above, but each word can use the 'super' identifier to
;; refer to its previous behaviour.
(define-syntax (parameterize/super-words stx)
  (parameterize/super-words-ns-tx
   #`(word-parameter #,@(stx-cdr stx))))




;; Reflection

;; Run time access uses symbols.
(define (ns-name ns [name '||])
  (syntax->datum
   (ns-prefixed (datum->syntax #f ns)
                (datum->syntax #f name))))

;; Unwrap the name, #f if not in ns.
(define (ns-name? ns)
  (let* ((prefix (symbol->string (ns-name ns)))
         (lp (string-length prefix)))
    (lambda (sym)
      (let* ((str (symbol->string sym))
             (l (string-length str)))
        (and (> l lp)
             (string=? prefix (substring str 0 lp))
             (string->symbol (substring str lp)))))))
  

;; Find all prefixed words in current namespace.
(define (ns-mapped-symbols ns)
  (let ((basename (ns-name? ns)))
    (foldl
     (lambda (sym collect)
       (let ((it (basename sym)))
         (if it (cons it collect) collect)))
     '()
     (namespace-mapped-symbols))))