(***********************************************************************)
(*                                                                     *)
(*                               TAToo                                 *)
(*                                                                     *)
(*                     Kim Nguyen, LRI UMR8623                         *)
(*                   Université Paris-Sud & CNRS                       *)
(*                                                                     *)
(*  Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
(*  Recherche Scientifique. All rights reserved.  This file is         *)
(*  distributed under the terms of the GNU Lesser General Public       *)
(*  License, with the special exception on linking described in file   *)
(*  ../LICENSE.                                                        *)
(*                                                                     *)
(***********************************************************************)
module Ast =
struct

  type path = single_path list
  and single_path = Absolute of step list | Relative of step list
  and step = axis * test * expr list
  and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
             | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following

  and test = Simple of QNameSet.t

  and binop = Eq | Neq | Lt | Gt | Lte | Gte | Or | And | Add | Sub | Mult | Div | Mod
  and unop =  Neg
  and expr =
    | Number of [ `Int of int | `Float of float ]
    | String of string
    | Fun_call of QName.t * expr list
    | Path of path
    | Binop of expr * binop * expr
    | Unop of unop * expr


  type t = path


  let text = QNameSet.singleton QName.text
  let node = QNameSet.any
  let star =
    QNameSet.complement (
      QNameSet.from_list [ QName.text;
                         QName.document;
                         QName.cdata_section;
                         QName.comment])
  let t_text = Simple text
  let t_node = Simple node
  let t_star = Simple star



  let pp fmt e = Format.fprintf fmt e

  let prio e = match e with
  | Unop (Neg, _) -> 11
  | Path _ -> 10
  | Number _ | String _ | Fun_call _ -> 9
  | Binop (_,op,_) -> begin match op with
    | Lt | Lte | Gt | Gte -> 7
    | Neq | Eq -> 6
    | And -> 5
    | Or -> 4
    | Mult | Div | Mod -> 3
    | Add | Sub -> 2
  end

  let print_binop fmt o =
    pp fmt "%s" begin match o with
    | Eq -> "="
    | Neq -> "!="
    | Lt -> "<"
    | Gt -> ">"
    | Lte -> "<="
    | Gte -> ">="
    | Or -> "or"
    | And -> "and"
    | Add -> "+"
    | Sub -> "-"
    | Mult -> "*"
    | Div -> "div"
    | Mod -> "mod"
    end
  let print_unop fmt o =
    pp fmt "%s" begin match o with
    | Neg -> "-"
    end

  let rec print_path fmt p =
    Pretty.print_list ~sep:" | " print_single_path fmt p

  and print_single_path fmt p =
    let l = match p with
      | Absolute l -> pp fmt "/"; l
      | Relative l -> l
    in
      Pretty.print_list ~sep:"/" print_step fmt l

  and print_step fmt (axis, test, expr) =
    pp fmt "%a::%a" print_axis axis print_test test;
    match expr with
      [] -> ()
    | l -> pp fmt "[ ";
        Pretty.print_list ~sep:" ][ " print_expr fmt l;
        pp fmt " ]"

  and print_axis fmt a = pp fmt "%s" (match a with
      Self -> "self"
    | Child -> "child"
    | Descendant -> "descendant"
    | DescendantOrSelf -> "descendant-or-self"
    | FollowingSibling -> "following-sibling"
    | Attribute -> "attribute"
    | Ancestor -> "ancestor"
    | AncestorOrSelf -> "ancestor-or-self"
    | PrecedingSibling -> "preceding-sibling"
    | Parent -> "parent"
    | Preceding -> "preceding"
    | Following -> "following"
  )
  and print_test fmt ts =
    try
      pp fmt "%s" (List.assoc ts
                     [ t_text,"text()";
                       t_node,"node()";
                       t_star, "*" ] )
    with
      Not_found -> pp fmt "%s"
        (match ts with
          Simple t -> if QNameSet.is_finite t
            then QName.to_string (QNameSet.choose t)
            else "<INFINITE>"
        )

  and print_expr fmt = function
    | Number (`Int(i)) -> pp fmt "%i" i
    | Number (`Float(f)) -> pp fmt "%f" f
    | String s -> pp fmt "'%S'" s
    | Fun_call (n, args) ->
        pp fmt "%a(" QName.print n;
        Pretty.print_list ~sep:", " print_expr fmt args;
        pp fmt ")"
    | Path p -> print_path fmt p
    | Binop (e1, op, e2) as e ->
        let pe = prio e in
        let need_par1 = prio e1 < pe in
        if need_par1 then pp fmt "(";
        pp fmt "%a" print_expr e1;
        if need_par1 then pp fmt ")";
        pp fmt " %a "  print_binop op;
        let need_par2 = prio e2 < pe in
        if need_par2 then pp fmt "(";
        pp fmt "%a" print_expr e2;
        if need_par2 then pp fmt ")"
    | Unop (op, e0) as e ->
        let need_par0 = prio e0 < prio e in
        print_unop fmt op;
        if need_par0 then pp fmt "(";
        print_expr fmt e0;
        if need_par0 then pp fmt ")"

end