ns-tx.rkt

#lang racket/base

;; All identifier mapping (prefix) code is hidden behind ns.ss and
;; ns-tx.ss code.

(provide
 ns-tx
 ns-prefixed
 name->identifier
 underscore-tx)

(require
 racket/pretty
 "tools/stx.rkt"
 (for-template
  racket/unit
  racket/base))

(define (underscore-tx name)
  (datum->syntax
   name
   (string->symbol
    (printf "_~a" (syntax->datum name)))))

(define ns-separator "/")

(define (ns->prefix-string ns-lst)
  (apply string-append
         (map (lambda (x) (format "~a~a" x ns-separator))
              ns-lst)))

(define (ns->prefix ns-stx)
  (ns->prefix-string
   (syntax->datum ns-stx)))

;; Forth macros are identified by symbols. For convenience strings,
;; are converted to identifier preserving lexical context and source
;; location.

(define (name->identifier stx)
  (let ((name (syntax->datum stx)))
    (cond
     ((symbol? name) stx)  
     ((string? name) (datum->syntax stx (string->symbol name) stx stx))
     (else
      (raise-syntax-error #f "ns form contains non-identifier (non-string)" stx)))))



;; Recertify in terms of original syntax.  Note that prefix-id doesn't recertify.
(define (ns-prefixed ns name)
  (syntax-recertify
   (prefix-id (ns->prefix ns)
              (name->identifier name))
   name (current-code-inspector) #f))



;; The syntax-property stuff doesn't work yet.  The point is to get
;; check-syntax to do the right thing..

;; Catch-all transformer.
(define (ns-tx stx)
  (syntax-case stx ()
    ((_ (namespace ... name))
     (ns-tx #`(_  (namespace ...) name)))
    ((_ (namespace ...) expr)
     (let* ((prefixed
             (lambda (n)
               (ns-prefixed #'(namespace ...) n)))
            (prefixed-list
             (lambda (stx)
               (map prefixed (syntax->list stx))))
            (prefixed-list-list
             (lambda (stx)
               (map prefixed-list (syntax->list stx))))
            (prefixed-letform
             (lambda (p)
               (lambda (binders)
                 (for/list ((b (syntax->list binders)))
                   (syntax-case b ()
                     ((n e) #`(#,(p #'n) e))))))))
       (if (identifier? #'expr)
           ;; REFERENCE
           (let ((id (prefixed #'expr)))
             (let ((sym (syntax->datum id))
                   (b (identifier-binding id)))
               ;; (unless b
               ;;   (raise-syntax-error #f "undefined variable after mangling" stx id))
               ;; (printf "~a : ~a\n" sym b)
               id))
           (let ((form?
                  (let ((form (car (syntax->datum #'expr))))
                    ;; (printf "form = ~a\n" form)
                    (lambda (symb) (eq? form symb)))))

             (syntax-case #'expr (extends)

               ;; BINDING
               ((form (name . a) e)
                (or (form? 'define)
                    (form? 'define-syntax))
                #`(form (#,(prefixed #'name) . a) e))
               
               ((form name e)
                (or (form? 'define)
                    (form? 'define-syntax))
                #`(form #,(prefixed #'name) e))

               ((form names e)
                (or (form? 'define-values)
                    (form? 'define-syntaxes))
                #`(form #,(prefixed-list #'names) e))

               ((form binders e)
                (or (form? 'let)
                    (form? 'letrec)
                    (form? 'shared))
                #`(form #,((prefixed-letform prefixed) #'binders) e))
               
               ((form binders e)
                (or (form? 'let-values)
                    (form? 'letrec-values))
                #`(form #,((prefixed-letform prefixed-list) #'binders) e))

               ;; MODULE
               ((form . specs)
                (or (form? 'combine-out))
                #`(form #,@(for/list ((spec (syntax->list #'specs)))
                             (ns-tx #`(ns (namespace ...) #,spec)))))

               ((form spec (old new) ...)
                (or (form? 'rename-in))
                #`(form spec #,@(prefixed-list-list #'((old new) ...))))

               ((form spec name ...)
                (or (form? 'except-in))
                #`(form spec #,@(prefixed-list #'(name ...))))

               ;; UNIT
               ((form unit-name extends sig^ (name ...))
                (or (form? 'define-signature))
                #`(form unit-name extends sig^ #,(prefixed-list #'(name ...))))

               ;; UNIT
               ((form unit-name (name ...))
                (or (form? 'define-signature))
                #`(form unit-name #,(prefixed-list #'(name ...))))
               
               

;; THIS JUST NEEDS PORTING               
;;                     ((_ unit-name (sig-id ...))
;;                      (id-in? #'define-signature)
;;                      #`(#,form-id unit-name
;;                                   #,(for/list ((si (in-stx #'(sig-id ...))))
;;                                       (syntax-case si (define-syntaxes)
;;                                         ((define-syntaxes (name ...) expr)
;;                                          #`(define-syntaxes #,(prefixed-list #'(name ...)) expr))
;;                                         ((other-form ...)
;;                                          #`(other-form ...))  ;; might need extension later..
;;                                         (id
;;                                          (prefixed #'id))))))
                              

               )))))))


;; *** postprocessor ***

;; The implementation with 'expand-to-top-form gives obscure errors
;; from time to time, producing identifiers that are not visible in
;; the caller's namespace for reasons unknown to me.

;; While it is a bit tedious to spell out all possible forms to be
;; transformed by the ns mechanism, doing so seems a lot better than
;; having to deal with macro system internals that are exposed by
;; calling the expander directly.

;; ;; Catch-all transformer       
;; (define (ns-tx stx)
;;   (syntax-case stx ()
;;     ((_ (namespace ... name))
;;      (ns-tx #`(_  (namespace ...) name)))
;;     ((_ (namespace ...) expr)
;;      (let* ((prefixed
;;              (lambda (n)
;;                (ns-prefixed #'(namespace ...) n)))
;;             (prefixed-list
;;              (lambda (stx)
;;                (map prefixed (syntax->list stx))))
;;             (prefixed-list-list
;;              (lambda (stx)
;;                (map prefixed-list (syntax->list stx))))
;;             (prefixed-binders
;;              (lambda (p)
;;                (lambda (binders)
;;                  (for/list ((b (syntax->list binders)))
;;                    (syntax-case b ()
;;                      ((n e) #`(#,(p #'n) e))))))))
;;        (if (identifier? #'expr)
;;            ;; REFERENCE
;;            (prefixed #'expr)
;;            (let ((form?
;;                   (let ((form (car (syntax->datum #'expr))))
;;                     (lambda (symb) (eq? form symb)))))

;;              (syntax-case #'expr ()

;;                ;; MODULE
;;                ((form . specs)
;;                 (form? 'combine-out)
;;                 #`(form #,@(for/list ((spec (syntax->list #'specs)))
;;                              (ns-tx #`(ns (namespace ...) #,spec)))))

;;                ((form spec (old new) ...)
;;                 (form? 'rename-in)
;;                 #`(form spec #,@(prefixed-list-list #'((old new) ...))))

;;                ((form spec name ...)
;;                 (form? 'except-in)
;;                 #`(form spec #,@(prefixed-list #'(name ...))))


;;                ;; BINDINGS
               
;;                ;; Here it's easier to expand the top form to reveal
;;                ;; primitive binding forms, since there are many forms
;;                ;; that bind names.
;;                (else
;;                 (let* ((form     (expand-syntax-to-top-form #'expr))
;;                        (form-sym (syntax->datum (car (syntax->list form))))
;;                        (form-id  #f)
;;                        (id-in?    (lambda ids
;;                                     (for/or ((id ids))
;;                                             (set! form-id id)
;;                                             (eq? form-sym (syntax->datum id))))))

;;                   (pretty-print (syntax->datum form))

;;                   (unless (symbol? form-sym)
;;                     (raise-syntax-error #f "bad ns form" stx))
;;                   (syntax-case form ()
               
;;                     ((_ (name . formals) . body)
;;                      (id-in? #'define
;;                              #'define-syntax)
;;                      #`(#,form-id (#,(prefixed #'name) . formals) . body))
                    
;;                     ((_ name expr)
;;                      (id-in? #'define
;;                              #'define-syntax)
;;                      #`(#,form-id #,(prefixed #'name) expr))

;;                     ((_ (name ...) expr)
;;                      (id-in? #'define-values
;;                              #'define-syntaxes)
;;                      #`(#,form-id #,(prefixed-list #'(name ...)) expr))
                    
;;                     ((_ binders . body)
;;                      (id-in? #'let-values
;;                              #'let*-values
;;                              #'letrec-values)
;;                      #`(#,form-id #,((prefixed-binders prefixed-list) #'binders) . body))

;;                     ((_ unit-name (sig-id ...))
;;                      (id-in? #'define-signature)
;;                      #`(#,form-id unit-name
;;                                   #,(for/list ((si (in-stx #'(sig-id ...))))
;;                                       (syntax-case si (define-syntaxes)
;;                                         ((define-syntaxes (name ...) expr)
;;                                          #`(define-syntaxes #,(prefixed-list #'(name ...)) expr))
;;                                         ((other-form ...)
;;                                          #`(other-form ...))  ;; might need extension later..
;;                                         (id
;;                                          (prefixed #'id))))))
               
;;                     (else
;;                      (begin
;;                        (printf "WARNING: ns-tx doesn't match top form:\n")
;;                        (pretty-print (syntax->datum form))
;;                        (pretty-print (syntax->datum (expand-to-top-form form)))
;;                        #'expr))))))))))))


;;   ;; Notes:
;;   ;;
;;   ;; * It's not ok to insert the toplevel form's identifier back into
;;   ;;   the syntax object, since its bindings are (probably) not
;;   ;;   visible in the user's context.  I'm using the bindings visible
;;   ;;   from here.
;;   ;;
;;   ;; * For some reason including identifiers in the syntax-case
;;   ;;   literal list won't match them properly, so I use guards that
;;   ;;   match the symbol instead.