#lang scheme/base

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

(provide
 let-ns-tx          ;; introduce lexical names in namespace
;; with-rpn-ns        ;; parameterize compiler with namespace
 define-ns-tx
 redefine!-ns-tx
 definitions-ns-tx

 redefine!-tx       ;; used in forth-begin.ss
 
 parameterize-words-ns-tx
 parameterize/super-words-ns-tx

 ns-prefixed
 make-ns-ref   ;; used in with-macro's rpn-map-identifier
 make-ns-bind
 name->identifier
)
(require
 (lib "pretty.ss")
 scheme/stxparam
 syntax/modcode
 syntax/modresolve
 scheme/pretty
 mzlib/pregexp
 "../tools-tx.ss"
 (for-template
  "../tools.ss"
  "rep.ss" ;; word-swap!
  scheme/base
  )
 )

;; *** SYMBOL MAPPING ***
;;
;; 1. name reference

;; (The resulting macro can be used in an rpn-map-identifier.  See the
;; 'word' macro in macro.ss / used in macro-tx.ss)

(define (make-ns-ref ns)
  (lambda (stx)
    (syntax-case stx ()
      ((_ id)
       (ns-prefixed ns #'id)))))

;; 2. name introduction
;; Create a transformer that behaves as 'let' or 'let-values', but maps names.

(define (make-ns-bind let ns)
  (lambda (stx)
    (syntax-case stx ()
      ((_ ((name/names expr) ...) body ...)
       #`(#,let
             #,(map
                (lambda (n/ns e)
                  #`(#,(syntax-case n/ns ()
                         ((name ...)
                          (map (lambda (n) (ns-prefixed ns n))
                               (syntax->list #'(name ...))))
                         (name
                          (ns-prefixed ns #'name)))
                     #,e))
                (syntax->list #'(name/names ...))
                (syntax->list #'(expr ...)))
           body ...)))))


;; *** TOOLS ***

;; FIXME: change this to find hardcoded occurences of prefix
;; pick a separator that has no special meaning in regexps
(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)
  (->syntax ns-stx
            (string->symbol
             (ns->prefix-string
              (->datum ns-stx)))))

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

(define (name->identifier stx)
  (let ((name (syntax->datum stx)))
    (cond
     ((symbol? name) stx)  
     ((string? name) (datum->syntax stx (string->symbol name)))
     (else #f))))


(define (ns-prefixed ns name)  (prefix (ns->prefix ns)
          (name->identifier name)))


;; *** NS.SS TRANSFORMER CORES ***

(define (let-ns-tx stx)
  (syntax-case stx ()
    ((let ns . args)
     #`(let-syntax
           ((let/ns (make-ns-bind #'let #'ns)))
         (let/ns . args)))))

(define (define-ns-tx stx)
  (syntax-case stx ()
    ;; ((_ _ #f effect!) ;; see redefine!-ns-tx
    ;;  #`(void effect!))
    ((define ns name val)
     (let ((mapped (ns-prefixed #'ns #'name)))
       #`(define #,mapped val)))))

;; Like define-ns-tx, but with redefine allowed. Implemented in 2
;; steps: make self-referencing word called 'super' + swap with word
;; already bound to name. This is used to build specializations of
;; core compiler code instantiated in a namespace for a specific
;; target, by modifing the provided word structures.

;; (define (redefine!-ns-tx stx)     
;;   (syntax-case stx ()
;;     ;; ((_ _ #f effect!)
;;      ;; If name is not present, do not define anything, but evaluate
;;      ;; the expression for side-effect. This is used in forth prelude
;;      ;; code, which will define a forth word (with no name) but not a
;;      ;; corresponding macro. See forth/forth-tx.ss.
;;     ;; #`(void effect!))
;;     ((define ns name val)
;;      (let ((id (ns-prefixed #'ns #'name)))
;;        (if (identifier-binding id)
;;            (let ((super
;;                   (ns-prefixed
;;                    #'ns (datum->syntax #'name 'super))))
;;              #`(letrec ((#,super val))
;;                  (log: ;; #:tag 'extend
;;                        "~a ~a\n" 'ns 'name)
;;                  (word-swap! #,super #,id)))  ;; swap! emulates boxed word
;;            #`(define #,id val))))))



(define (redefine!-tx map-id stx)
  (syntax-case stx ()
    ((define name val)
     (let ((id (map-id #'name)))
       (if (identifier-binding id)
           (let ((super (map-id (datum->syntax #'name #'super))))
             #`(letrec ((#,super val))
                 (log: "~a\n" ' #,id)
                 (word-swap! #,super #,id)))  ;; word-swap! emulates boxed word
           #`(define #,id val))))))

(define (redefine!-ns-tx stx)
  (syntax-case stx ()
    ((define ns name val)
     (redefine!-tx (lambda (id) (ns-prefixed #'ns id))
                   #`(define name val)))))

;; Multiple of the above, ala 'compositions'.
(define (definitions-ns-tx stx)
  (syntax-case stx ()
    ((define-ns ns (name val) ...)
     #`(begin (define-ns ns name val) ...))))




;; The parameter approch is like define/swap!-ns-tx, but uses
;; parameter words to provide non-permanent extensions within a single
;; namespace. This is used for ";" for example.

(define (suffix-temp stx-lst suffix)
  (generate-temporaries
   (map (lambda (id)
          (format "~a~a" id suffix))
        (syntax->datum stx-lst))))

;; Simple word parameterization.
(define (parameterize-words-ns-tx stx)
  (syntax-case stx ()
    ((word->param ns ((name expr) ...) body ...)
     #`(let-syntax
           ((id  (make-ns-ref #'ns)))
         (parameterize
             (((word->param (id name)) expr) ...)
           body ...)))))

;; Word parameters on top of 'parameterize with 'super'. Extracts
;; parameters and binds the values so they can be bound to the
;; introduced identifier 'super'.

;; NOTE: Staapl uses refine!-ns-tx, a simpler machanism built atop of
;; boxed functions.
(define (parameterize/super-words-ns-tx stx)
  (syntax-case stx ()
    ((_ _ () body ...) #`(let () body ...)) ;; fend off
    ((word->param ns ((name expr) ...) body ...)
     (syntax-case
         (list
          (ns-prefixed #'ns
                       (datum->syntax
                        (stx-car #'(name ...))
                        'super))
          (suffix-temp #'(name ...) "-param-")   ;; name for parameter object
          (suffix-temp #'(name ...) "-value-"))  ;; previous parameter value
         ()
       ((super (pname ...) (pvalue ...))
        #`(let-syntax
              ((_ns (make-ns-ref #'ns)))
            (let ((pname (word->param (_ns name))) ...)
              (let ((pvalue (pname)) ...)
                (parameterize
                    ((pname (let ((super pvalue)) expr)) ...)
                  body ...)))))))))