(***********************************************************************) (* *) (* 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. *) (* *) (***********************************************************************) 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 of bool (* true = descendant-or-self, false = descendant *) | FollowingSibling | Parent | Ancestor of bool (* true = ancestor-or-self, false = ancestor *) | PrecedingSibling | Preceding | Following and test = QNameSet.t * Tree.NodeKind.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.comment]) 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" begin match a with Self -> "self" | Child -> "child" | Descendant false -> "descendant" | Descendant true -> "descendant-or-self" | FollowingSibling -> "following-sibling" | Attribute -> "attribute" | Ancestor false -> "ancestor" | Ancestor true -> "ancestor-or-self" | PrecedingSibling -> "preceding-sibling" | Parent -> "parent" | Preceding -> "preceding" | Following -> "following" end and print_test fmt (ts,kind) = let open Tree.NodeKind in match kind with Text -> pp fmt "%s" "text()" | Element | Attribute -> pp fmt "%s" begin if QNameSet.is_finite ts then QName.to_string (QNameSet.choose ts) else "*" end | Comment -> pp fmt "%s" "comment()" | ProcessingInstruction -> pp fmt "processing-instruction(%s)" begin if ts == star then "" else "\"" ^ (QName.to_string (QNameSet.choose ts)) ^ "\"" end | Node -> pp fmt "%s" "node()" | Document -> pp fmt "%s" "" 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 ")" let invert_axis = function | Self -> Self | Attribute -> Parent (* Improve *) | Child -> Parent | Descendant (b) -> Ancestor (b) | FollowingSibling -> PrecedingSibling | Parent -> Child | Ancestor (b) -> Descendant (b) | PrecedingSibling -> FollowingSibling | Preceding -> Following | Following -> Preceding ;;