#lang scheme/base

(require
 "../ns.ss"
 (for-syntax
  scheme/base
  scheme/pretty
  "../ns-tx.ss"
  "parse-tx.ss"))

(provide (all-defined-out))

;; An RPN transformer is a primitive taking arguments
;;   W : code stack
;;   D : dictionary (parser output)
;;   K : parser continuation



;; RPN PARSER

;; (rpn-parse (mk semantics ...) code ...)

;; The rpn syntax is currently implemented as a single transformer to
;; be able to get at the provided semantics macros through lexical
;; scope.  (Previous implementation used compile-time paramters, which
;; became hard to understand.)

;; The parser can be parameterized as follows:
;;   * semantics for built-in in RPN language constructs.
;;   * prefix parsers bound to local syntax
;;   * prefix parsers found in the input stream

(define-syntax (rpn-parse stx)
  (let ((args (stx-args stx)))
    (syntax-case (car args) ()
      ((tx-dict    ;; macro continuation <- dictionary output form
        (ns ...)   ;; identifier namespace
        function   ;; semantics macros for different forms
        immediate
        immediate-program
        program:
        init-dict)
       (let*
           ((map-id ;; (1)
             (lambda (id)
               (ns-prefixed #'(ns ...) id)))
            (->parse
             (lambda (it)
               (and (rpn-transformer? it)
                    (rpn-transformer-tx it))))
            (mapped-syntax-value
             (lambda (stx)
               (and (identifier? stx)
                    (syntax-local-value (map-id stx)
                                        (lambda () #f)))))
            (qq
             ;; Build a quasiquoted immediate by traverseing an sexp
             ;; tree and performing proper unquotes.
             (lambda (unquote-tx)
               (lambda (atom-stx)
                 (define (uq stx)
                   (syntax-case stx (unquote)
                     ((unquote atom) (unquote-tx #'atom))
                     ((car . cdr)    #`(#,(uq #'car) . #,(uq #'cdr)))
                     (atom           #'atom)))
                 #`(immediate (quasiquote #,(uq atom-stx))))))
                
            (quoter
             ;; All quoters take one arguement.
             (lambda (fn stx)
               (syntax-case stx ()
                 ((_ atom) (fn #'atom))
                 (other    (raise-syntax-error
                            #f "takes a single argument" stx)))))
            (quoted
             ;; Quote supports unquote as a way to introduce
             ;; arbitrary scheme values into s-expressions.
             (qq (lambda (atom) #`(unquote #,atom))))
            (quasiquoted
             ;; Quasiquotation is intended to build datastructures
             ;; containing function objects, not to substitute
             ;; scheme values.  It supports both identifiers and
             ;; compositions.
             (qq (lambda (atom)
                   (syntax-case atom ()
                     ((e ...) #`(unquote (program: e ...)))
                     (e       #`(unquote #,(map-id #'e)))))))
            (unquoted
             ;; Unquote takes an expression from the surrounding
             ;; Scheme environment and uses it as a function.
             (lambda (atom-stx)
               #`(function #,atom-stx)))

            (primitive
             (lambda (element)
               (syntax-case element
                   (quote quasiquote unquote) 
                 ((quote . e)        (quoter quoted element))
                 ((quasiquote . e)   (quoter quasiquoted element))
                 ((unquote . e)      (quoter unquoted element))
                 ((e ...)            #`(immediate-program (program: e ...)))
                 (e (if (identifier? #'e)
                        #`(function (ns ... e))
                        #`(immediate #,element))))))
            (primitive-parse
             (lambda (element)
               (lambda (w d next)
                 (next (w-cdr w)
                       (d-compile
                        (primitive element) d))))))

         ;; * MAIN LOOP *
         ;; Read elements from the list of syntax elements, parse
         ;; and compile.  When done, pass the dictionary to the
         ;; dictionary transformer macro.
         (let next ((w (cdr args))
                    (d (foldl d-compile
                              (d-create)
                              (syntax->list #'init-dict))))
           (if (w-null? w)
               (let ((forms (d->forms d)))
                 ;; (pretty-print (syntax->datum #`( #,@forms )))
                 #`(tx-dict #,@forms))
               (let* ((element (w-car w))
                      (parse
                       ;; Determine if the element represents a parser
                       ;; extension.  Either directly in the input
                       ;; stream, possibly wrapped in a syntax object,
                       ;; or bound to a transformer binding.
                       (or (->parse element)
                           (->parse (syntax->datum element))
                           (->parse (mapped-syntax-value element))
                           (primitive-parse element))))

                 ;; All parsers are invoked in tail position and need
                 ;; to call 'next to continue looping with updated
                 ;; state.
                 (parse w d next)))))))))


;; Notes
;;
;; (1) In order to access transformer bindings containing
;;     rpn-transformer instances, compile time identifiers specified
;;     by the form (namespace ... id) are _interpreted_ : the form
;;     which is a valid macro form is _not_ expanded.  This is to
;;     prevend recursive macro expansion inside the rpn-parse macro,
;;     which I've not been able to figure out how to do correctly.
;;     (i.e. using 'local-expand ...).  However, if this process fails
;;     and no transformer binding is found, the identifier is replaced
;;     with the form in the output of rpn-parse, which allows for
;;     abstract identifier mapping.