Simplify the automaton encoding a bit (remove redundant predicates in formulae).
[tatoo.git] / src / xpath / ast.ml
1 (***********************************************************************)
2 (*                                                                     *)
3 (*                               TAToo                                 *)
4 (*                                                                     *)
5 (*                     Kim Nguyen, LRI UMR8623                         *)
6 (*                   Universit√© Paris-Sud & CNRS                       *)
7 (*                                                                     *)
8 (*  Copyright 2010-2012 Universit√© Paris-Sud and Centre National de la *)
9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
10 (*  distributed under the terms of the GNU Lesser General Public       *)
11 (*  License, with the special exception on linking described in file   *)
12 (*  ../LICENSE.                                                        *)
13 (*                                                                     *)
14 (***********************************************************************)
15
16 type path = single_path list
17 and single_path = Absolute of step list | Relative of step list
18 and step = axis * test * expr list
19 and axis = Self | Attribute | Child
20            | Descendant of bool  (* true = descendant-or-self, false = descendant *)
21            | FollowingSibling
22            | Parent
23            | Ancestor of bool (* true = ancestor-or-self, false = ancestor *)
24            | PrecedingSibling
25            | Preceding | Following
26
27 and test = QNameSet.t * Tree.NodeKind.t
28
29 and binop = Eq | Neq | Lt | Gt | Lte | Gte | Or | And | Add | Sub | Mult | Div | Mod
30 and unop =  Neg
31 and expr =
32   | Number of [ `Int of int | `Float of float ]
33   | String of string
34   | Fun_call of QName.t * expr list
35   | Path of path
36   | Binop of expr * binop * expr
37   | Unop of unop * expr
38
39
40 type t = path
41
42
43 let text = QNameSet.singleton QName.text
44 let node = QNameSet.any
45 let star =
46   QNameSet.complement (
47     QNameSet.from_list [ QName.text;
48                          QName.document;
49                          QName.comment])
50
51
52
53 let pp fmt e = Format.fprintf fmt e
54
55 let prio e =
56   match e with
57   | Unop (Neg, _) -> 11
58   | Path _ -> 10
59   | Number _ | String _ | Fun_call _ -> 9
60   | Binop (_,op,_) -> begin match op with
61     | Lt | Lte | Gt | Gte -> 7
62     | Neq | Eq -> 6
63     | And -> 5
64     | Or -> 4
65     | Mult | Div | Mod -> 3
66     | Add | Sub -> 2
67   end
68
69 let print_binop fmt o =
70   pp fmt "%s" begin match o with
71   | Eq -> "="
72   | Neq -> "!="
73   | Lt -> "<"
74   | Gt -> ">"
75   | Lte -> "<="
76   | Gte -> ">="
77   | Or -> "or"
78   | And -> "and"
79   | Add -> "+"
80   | Sub -> "-"
81   | Mult -> "*"
82   | Div -> "div"
83   | Mod -> "mod"
84   end
85 let print_unop fmt o =
86   pp fmt "%s" begin match o with
87   | Neg -> "-"
88   end
89
90 let rec print_path fmt p =
91   Pretty.print_list ~sep:" | " print_single_path fmt p
92
93 and print_single_path fmt p =
94   let l = match p with
95   | Absolute l -> pp fmt "/"; l
96   | Relative l -> l
97   in
98   Pretty.print_list ~sep:"/" print_step fmt l
99
100 and print_step fmt (axis, test, expr) =
101   pp fmt "%a::%a" print_axis axis print_test test;
102   match expr with
103     [] -> ()
104   | l -> pp fmt "[ ";
105       Pretty.print_list ~sep:" ][ " print_expr fmt l;
106       pp fmt " ]"
107
108 and print_axis fmt a = pp fmt "%s" begin
109   match a with
110     Self -> "self"
111   | Child -> "child"
112   | Descendant false -> "descendant"
113   | Descendant true -> "descendant-or-self"
114   | FollowingSibling -> "following-sibling"
115   | Attribute -> "attribute"
116   | Ancestor false -> "ancestor"
117   | Ancestor true -> "ancestor-or-self"
118   | PrecedingSibling -> "preceding-sibling"
119   | Parent -> "parent"
120   | Preceding -> "preceding"
121   | Following -> "following"
122 end
123
124 and print_test fmt (ts,kind) =
125   let open Tree.NodeKind in
126     match kind with
127       Text -> pp fmt "%s" "text()"
128     | Element | Attribute ->
129         pp fmt "%s" begin
130           if QNameSet.is_finite ts then
131             QName.to_string (QNameSet.choose ts)
132           else "*"
133         end
134     | Comment -> pp fmt "%s" "comment()"
135     | ProcessingInstruction ->
136         pp fmt "processing-instruction(%s)"
137           begin
138             if ts == star then ""
139             else "\"" ^ (QName.to_string  (QNameSet.choose ts)) ^ "\""
140           end
141     | Node -> pp fmt "%s" "node()"
142     | Document -> pp fmt "%s" "<DOCUMENT>"
143
144 and print_expr fmt = function
145 | Number (`Int(i)) -> pp fmt "%i" i
146 | Number (`Float(f)) -> pp fmt "%f" f
147 | String s -> pp fmt "'%S'" s
148 | Fun_call (n, args) ->
149     pp fmt "%a(" QName.print n;
150     Pretty.print_list ~sep:", " print_expr fmt args;
151     pp fmt ")"
152 | Path p -> print_path fmt p
153 | Binop (e1, op, e2) as e ->
154     let pe = prio e in
155     let need_par1 = prio e1 < pe in
156     if need_par1 then pp fmt "(";
157     pp fmt "%a" print_expr e1;
158     if need_par1 then pp fmt ")";
159     pp fmt " %a "  print_binop op;
160     let need_par2 = prio e2 < pe in
161     if need_par2 then pp fmt "(";
162     pp fmt "%a" print_expr e2;
163     if need_par2 then pp fmt ")"
164 | Unop (op, e0) as e ->
165     let need_par0 = prio e0 < prio e in
166     print_unop fmt op;
167     if need_par0 then pp fmt "(";
168     print_expr fmt e0;
169     if need_par0 then pp fmt ")"
170
171
172
173 let invert_axis = function
174 | Self -> Self
175 | Attribute -> Parent (* Improve *)
176 | Child -> Parent
177 | Descendant (b) -> Ancestor (b)
178 | FollowingSibling -> PrecedingSibling
179 | Parent -> Child
180 | Ancestor (b) -> Descendant (b)
181 | PrecedingSibling -> FollowingSibling
182 | Preceding -> Following
183 | Following -> Preceding
184 ;;