; Copyright 2005 Kevin Reid, under the terms of the MIT X license
; found at http://www.opensource.org/licenses/mit-license.html ................

(in-package :e.elang.syntax)

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; this is necessary because cl-yacc evaluates the action forms at macroexpansion time. XXX report as bug (precedent: eql specializers in defmethod)
  
  (defun second-arg (a b &rest c) (declare (ignore a c)) b)
  
  (defun binop (left op right) 
    ;; XXX trimming bad
    (e. *b* |binop| (string-trim '(#\Space #\Newline #\Return #\Tab) op) left right))
  
  (defmacro il (args &body body)
    `(lambda ,args
       (declare (ignorable ,@args))
       ,@body))
  
  (defmacro build (in &rest out)
    `(il ,in (e. *b* ,@out))))

(defparameter *b* (e-lambda "$builder" ()
  ;; xxx implements EBuilder
  (:|assign| (l r) 
    ;; XXX needs to expand some structures
    (make-instance '|AssignExpr| :elements (list l r)))
  (:|define| (l r) 
    ;; XXX needs to expand cyclic defines
    (make-instance '|DefineExpr| :elements (list l r nil)))
  (:|finalPattern| (noun guard)
    (make-instance '|FinalPattern| :elements (list (make-instance '|NounExpr| :elements (list noun)) guard)))
  (:|varPattern| (noun guard)
    (make-instance '|VarPattern| :elements (list (make-instance '|NounExpr| :elements (list noun)) guard)))
  (:|slotPattern| (noun guard)
    (make-instance '|SlotPattern| :elements (list (make-instance '|NounExpr| :elements (list noun)) guard)))
  (:|_noun| (noun)
    "XXX what should this really be?"
    (make-instance '|NounExpr| :elements (list noun)))
  (:|literal| (value)
    "XXX interface doc says 'tokenOrData'"
    (make-instance '|LiteralExpr| :elements (list value)))
  (:|sequence| (subs)
    (e-coercef subs 'vector)
    (make-instance '|SeqExpr| :elements (coerce subs 'list)))
  (:|hide| (expr)
    (make-instance '|HideExpr| :elements (list expr)))
  (:|ifx| (test then else)
    (make-instance '|IfExpr| :elements (list test then else)))
  
  (:|update| (l verb r)
    (make-instance '|AssignExpr| :elements (list l (make-instance '|CallExpr| :elements (list l verb r)))))
  (:|uriExpr| (uri)
    ;; XXX messy
    (e-coercef uri 'string)
    (make-instance '|CallExpr| :elements (list
      (make-instance '|NounExpr| :elements (list (concatenate 'string (subseq uri 0 (position #\: uri)) "__uriGetter")))
      "get"
      (make-instance '|LiteralExpr| :elements (list (subseq uri (1+ (position #\: uri))))))))))

(defvar *cy-e-parser*)

(define-parser *cy-e-parser*
  (:start-symbol root)
  (:terminals (e.lex::linesep e.lex::assign e.lex::ident e.lex::uri e.lex::semi e.lex::int e.lex::string e.lex::float64 e.lex::div  e.lex::linesep e.lex::lcurly e.lex::rcurly e.lex::lparen e.lex::rparen e.lex::plus-assign e.lex::colon e.lex::comma e.lex::scope e.lex::question e.lex::lbrack e.lex::rbrack e.lex::matchbind e.lex::dot
               e.lex::till     
               e.lex::thru     
               e.lex::same     
               e.lex::notsame  
               e.lex::floordiv 
               e.lex::div      
               e.lex::plus     
               e.lex::minus    
               e.lex::star     
               e.lex::rem      
               e.lex::mod      
               e.lex::aba      
               e.lex::sl       
               e.lex::le       
               e.lex::lt       
               e.lex::lor      
               e.lex::bor      
               e.lex::land     
               e.lex::band     
               e.lex::pow      
               e.lex::sr       
               e.lex::ge       
               e.lex::gt
               . #.e.lex::e-keywords))
  (:precedence ((:nonassoc e.lex::pow)
                (:left e.lex::star e.lex::div e.lex::floordiv e.lex::mod e.lex::rem)
                (:left e.lex::plus e.lex::minus)
                (:left e.lex::sl e.lex::sr)
                (:nonassoc e.lex::till e.lex::thru)
                (:nonassoc e.lex::lt e.lex::gt e.lex::le e.lex::ge e.lex::aba)
                (:nonassoc e.lex::band e.lex::bor e.lex::butnot)
                (:nonassoc e.lex::same e.lex::notsame e.lex::matchbind e.lex::mismatch)
                (:left e.lex::land)
                (:left e.lex::lor)
                (:left e.lex::colon)
                (:right e.lex::assign)
                (:left e.lex::semi e.lex::linesep)))
   
  (root
    big-expr
    ()
    (e.lex::matchbind pattern #'second-arg))
  
  (big-expr 
    (big-expr stsep statement (build (l #:_ r) |sequence| (vector l r)))
    statement)
  
  (stsep e.lex::semi e.lex::linesep)
  
  (statement
    assignish
    (e.lex::def noun)
    (e.lex::defless-pattern e.lex::assign statement)
    (e.lex::def pattern e.lex::assign statement
      (build (#:_ p #:_ e) |define| p e)))
  
  (assignish
    arith
    (noun e.lex::assign arith (build (l op r) |assign| l r))
    (noun e.lex::plus-assign arith (build (l op r) |update| l "add" r)))
  
  (arith
    (arith e.lex::matchbind pattern)
    (arith e.lex::mismatch pattern)
    (arith e.lex::till     arith #'binop)
    (arith e.lex::thru     arith #'binop)
    (arith e.lex::same     arith #'binop)
    (arith e.lex::notsame  arith #'binop)
    (arith e.lex::floordiv arith #'binop)
    (arith e.lex::div      arith #'binop)
    (arith e.lex::plus     arith #'binop)
    (arith e.lex::minus    arith #'binop)
    (arith e.lex::star     arith #'binop)
    (arith e.lex::rem      arith #'binop)
    (arith e.lex::mod      arith #'binop)
    (arith e.lex::aba      arith #'binop)
    (arith e.lex::sl       arith #'binop)
    (arith e.lex::le       arith #'binop)
    (arith e.lex::lt       arith #'binop)
    (arith e.lex::lor      arith #'binop)
    (arith e.lex::bor      arith #'binop)
    (arith e.lex::land     arith #'binop)
    (arith e.lex::band     arith #'binop)
    (arith e.lex::pow      arith #'binop)
    (arith e.lex::sr       arith #'binop)
    (arith e.lex::ge       arith #'binop)
    (arith e.lex::gt       arith #'binop)
    ; (arith e.lex::colon    arith (build (l #:_ r) |cast| l r))
    atomic-expr)
  
  (atomic-expr
    literal
    noun
    (e.lex::band noun) ;; SlotExpr
    (e.lex::uri (build (s) |uriExpr| s))
    (brace-expr (build (e) |hide| e))
    parens-expr
    (e.lex::lbrack arglist e.lex::rbrack)
    (e.lex::if parens-expr brace-expr else
      (build (#:_ test then else) |ifx| test then else))
    (e.lex::escape pattern brace-expr)
    (e.lex::escape pattern brace-expr e.lex::catch pattern brace-expr)
    
    (e.lex::meta e.lex::dot verb e.lex::lparen arglist e.lex::rparen)
    (e.lex::pragma e.lex::dot verb e.lex::lparen arglist e.lex::rparen)
    
    (atomic-expr e.lex::lparen arglist e.lex::rparen)
    (atomic-expr e.lex::lbrack arglist e.lex::rbrack))
  
  (arglist () args)
   
  (args
    (big-expr)
    (args e.lex::comma big-expr))

  (brace-expr 
    (e.lex::lcurly big-expr e.lex::rcurly #'second-arg)
    (e.lex::lcurly e.lex::rcurly (build (#:_ #:_) |null|)))
    
  (parens-expr (e.lex::lparen big-expr e.lex::rparen #'second-arg))
  
  (else
    ((build () |null|))
    (e.lex::else brace-expr (il (#:_ e) e)))

  (defless-pattern
    ;; those patterns which may be used in a DefineExpr without the 'def' keyword
    (e.lex::bind e.lex::ident)
    (e.lex::var e.lex::ident (build (s) |varPattern| s))
    (e.lex::var e.lex::ident e.lex::colon atomic-expr (build (v s c g) |varPattern| s g))
    )

  (pattern
    defless-pattern
    (pattern e.lex::question atomic-expr)
    (e.lex::ident (build (s) |finalPattern| s nil))
    (e.lex::ident e.lex::colon atomic-expr (build (s #:_ g) |finalPattern| s g))
    (e.lex::band e.lex::ident (build (s) |slotPattern| s nil))
    (e.lex::band e.lex::ident e.lex::colon atomic-expr (build (#:_ s #:_ g) |slotPattern| s g)))
  
  (something-expr
    (somthing-expr s-property ident (build (e #:_ i) |readProperty| e i)))
  
  (noun
    (e.lex::ident (build (s) |_noun| s))
    (e.lex::scope e.lex::string (build (#:_ s) |_noun| s)))
  
  (verb
    e.lex::ident
    e.lex::string)
  
  (literal
    (e.lex::string (build (v) |literal| (read-from-string v))) ;; XXX implement E unquoting
    (e.lex::float64 (build (v) |literal| (let ((*read-default-float-format* 'double-float)) (read-from-string v)))) ; XXX variously bad
    (e.lex::int (build (v) |literal| (parse-integer v)))))

(defun e-source-to-tree (source)
  (let* ((lexer (e.lex:make-lexer))
         (tokens (append (funcall lexer source) (funcall lexer :eof))))
    (parse-with-lexer 
      (lambda ()
        (let ((pair (pop tokens)))
          (values (car pair) (cdr pair))))
      *cy-e-parser*)))