(ns eu.dnetlib.dlms.parser
  (:gen-class
   :name eu.dnetlib.dlms.ClojureDQLParser
   :implements [eu.dnetlib.dlms.jdbc.parser.IDQLParser]
   )
  (:use [eu.dnetlib.clojure.clarsec]
	[eu.dnetlib.dlms.ast]
	[eu.dnetlib.clojure.monad])
)

(declare instantiation invocation literal reference parameter select)
(declare xpath)

(defn quotedString [ch]
	(between (is-char ch) (is-char ch) (many (not-char ch))))

(def dqlStringLiteral
     (stringify (lexeme (either (quotedString \') (quotedString \")))))

(def expression
     (delay (either
	     instantiation
	     invocation
	     literal
	     reference
	     parameter)))
	     
(def anyReference
     (delay (either literal reference parameter)))

(def stringLit
     (>>== dqlStringLiteral make-string-lit))

(def number
     (>>== natural make-integer-lit))
     
(def dateLit 
     (lexeme (>>== (stringify (>> (string "#") (quotedString \')))
     		   make-date-lit)))

(def reference 
     (>>== identifier make-reference))

(def parameter
     (>>== (either (>> (symb "?") (stringify (many digit)))
     		   (>> (symb ":") baseIdentifier))
           make-parameter))

; accept a parser prefixed with a namespace ("dc:....")
(defn namespaced [p] 
     (either (stringify (m-sequence [baseIdentifier (string ":") p]))
	     p))

(def baseLabel
     (namespaced baseIdentifier))

(def label (lexeme baseLabel))

(def structureDef
     (let-bind [label label
		_     (symb "=")
		val   expression]
	       (result (make-struct-def label val))))

(def structure 
     (>>== (braces (sepBy structureDef comma))
	   make-struct))

(def collection
     (delay
     	(>>== (brackets (sepBy expression comma))
	      make-collection)))

(def literal
     (either collection structure dateLit number stringLit))
     
(def argList
     (delay (sepBy expression comma)))

(def instantiation
     (let-bind [_      (symb "new")
		set    identifier
		args   (parens argList)]
	       (result (make-instantiation set args))))

(def invocation
(delay
     (let-bind [target anyReference
		_      (string ".")
		method identifier
		args  (parens argList)]
		(result (make-call target method args)))))

(def assignmentExpression 
	(delay
	(either (>>== select make-expression-select) expression)))

(defn decl [typ]
  (let-bind [name identifier
	     _    (symb "=")
	     e    assignmentExpression]
	    (result (make-decl-init typ name e))))

(defn assign [name]
  (let-bind [_ (symb "=")
	     e assignmentExpression]
	    (result (make-assign name e))))

(def predecl
     (let-bind [name identifier]
	       (either (decl name) (assign name))))

(def baseTagname
     (namespaced (either (string "*") baseIdentifier)))

(def tagname
     (lexeme (either (symb ".")
		     (stringify (m-sequence [(optional (string "@")) baseTagname])))))

(def relPattern
     (let-bind [l tagname
                _ (symb "->")
                r tagname]
               (result (make-relation-pattern l r))))

(def tagnameExpr 
     (either (>>== (symb "*") (fn [_] (make-star-tag)))
             (>>== (parens (sepBy1 tagname (symb "|"))) make-static-tag-expression)
             (parens relPattern)
             (>>== tagname #(make-static-tag-expression [%])))) 

; added new binoperator 'in'ex:  @collField 
(def binaryOperator
     (apply either (map symb ["=" "~=" "<=" ">=" "<" ">" "!=" "contains" ]))) 

(def binaryPredicate
     (delay
      (let-bind [xp xpath
		 op binaryOperator
		 expr (either xpath (>>== expression make-xpath-expression))]
		(result (make-binary-predicate op xp expr)))))

(def predicate (delay (either binaryPredicate (>>== xpath make-simple-predicate))))

(def tagexp
     (delay
      (let-bind [axis (optional (followedBy identifier (symb "::")))
		 tag  tagnameExpr
		 pred (optional (brackets predicate))]
		(result (make-tagexp axis tag pred)))))


(def xpathTraversalOperator
     (either (string "//") (string "/")))

(def qualifiedTagexp
     (let-bind [q xpathTraversalOperator
		t tagexp]
	       (result (make-qualified-tagexp q t))))
 
(def unqualifiedTagexp 
     (either (>> (string "//") (>>== tagexp rooted-tagexp-qualifier))
             (>>== tagexp default-tagexp-qualifier)))
     
; rules for the first tag expression in a xpath: 
;  a   -> ./a
;  ./a -> ./a
;  //a -> //a
;  /a  -> illegal
;  //. -> illegal  (currently isn't enforced by the parser)
                
(def xpath 
     (delay 
      (>>== (m-sequence [unqualifiedTagexp (many qualifiedTagexp)])
            #(make-xpath (apply vector (apply concat %))))))

(def fieldList
     (sepBy identifier comma))

(def select
     (let-bind [_      (symb "select")
		fields (option [] (parens fieldList))
		xp     xpath
		limit  (optional (>> (symb "limit") natural))]
	       (result (make-select fields xp limit))))

(def statement 
     (either predecl
	     select
	     (>>== expression make-run-expr)))

(def body 
     (followedBy (sepBy1 statement semi) (optional semi)))

(def source
     (followedBy body (lexeme eof)))

(defn -main []
  (println (parse source "1")))

(defn -parse [this strn]
  (:value (parse source strn)))