5 let all_nodes tree = let root = Naive_tree.root tree in
6 eval_axis tree [root] (Descendant true)
8 let element_by_tag tree tagset kind = let dom = all_nodes tree in
10 Tree.NodeKind.is_a (Naive_tree.kind tree c) kind &&
11 QNameSet.mem (Naive_tree.tag tree c) tagset ) dom
13 let rec compile_single_path p =
16 | Absolute p | Relative p -> compile_step_list (List.rev p)
18 and compile_step_list p =
21 | (a,(test,kind),el) :: r ->
22 let qtree = compile_step_list r in
23 let res = Binop ( Inter,Axis (a,qtree), Tag (test,kind) ) in
24 List.fold_left (fun acc e ->
25 Binop(Inter, acc, compile_expr e)) res el
27 and compile_expr (e : Xpath.Ast.expr ) = match e with
28 | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
29 let qtree = compile_expr e0 in
30 Binop (Diff , Dom, qtree)
32 | Binop (e1,op,e2) -> let qtree1 = compile_expr e1 in
33 let qtree2 = compile_expr e2 in
36 | Or -> Binop (Union , qtree1,qtree2)
37 | And -> Binop (Inter ,qtree1,qtree2)
38 | _ -> failwith "Unknown operator"
40 | Path p -> compile_path_rev p
41 | _ -> failwith "Unknown expression"
43 and compile_path_rev p =
46 | [p] -> compile_single_path_rev p
47 | p::r -> List.fold_left (fun acc p -> Binop (Union , acc, compile_single_path_rev p) ) (compile_single_path_rev p) r
49 and compile_single_path_rev p =
51 | Absolute p | Relative p -> compile_step_list_rev p (*(List.rev p)*)
53 and compile_step_list_rev p = match p with
55 | (a,(test,kind),el) :: r ->
56 let qtree = compile_step_list_rev r in
57 let res = Binop (Inter , qtree, Tag(test,kind)) in
58 let qtree2 = List.fold_left (fun acc e ->
59 Binop(Inter, acc, compile_expr e)) res el in
60 let a_rev = axis_rev a in
71 if not b then (Ancestor false)
72 else (Ancestor true) (* true = descendant-or-self, false = descendant *)
73 | FollowingSibling -> PrecedingSibling
76 if not b then (Descendant false)
77 else (Descendant true) (* true = ancestor-or-self, false = ancestor *)
78 | PrecedingSibling -> FollowingSibling
79 | Preceding -> Following
80 | Following -> Preceding
83 let compile_xpath p = match p with
85 | [p] -> compile_single_path p
86 | p::r -> List.fold_left (fun acc p -> Binop (Union , acc, compile_single_path p) ) (compile_single_path p) r
88 let comp_node t n1 n2 = (Naive_tree.preorder t n1) < (Naive_tree.preorder t n2)
91 let rec union_list t l1 l2 =
95 | h1::ll1, h2::ll2 -> if (comp_node t h2 h1) then h2 :: (union_list t l1 ll2)
96 else if (comp_node t h1 h2) then h1::(union_list t ll1 l2)
97 else h1 ::(union_list t ll1 ll2)
99 let rec inter_list t l1 l2 =
103 | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then inter_list t ll1 l2
104 else if (comp_node t h2 h1) then inter_list t l1 ll2
105 else h1 :: (inter_list t ll1 ll2)
107 let rec diff_list t l1 l2 =
111 | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then h1::(diff_list t ll1 l2)
112 else if (comp_node t h2 h1) then h2 :: (diff_list t l1 ll2)
113 else diff_list t ll1 ll2
116 let do_debug = ref false
119 if !do_debug then begin
120 Format.fprintf Format.std_formatter "Evaluation de: ";
121 print_query_tree Format.std_formatter q;
122 Format.fprintf Format.std_formatter "\nResultat: %i\n"
124 Format.pp_print_flush Format.std_formatter ();
125 print_node_list tree l;
127 (fun n -> Format.fprintf Format.std_formatter "%i, " (Naive_tree.preorder tree n)) l;*)
128 Format.fprintf Format.std_formatter "\n----------------\n";
129 Format.pp_print_flush Format.std_formatter ();
132 let table_query_tree = Hashtbl.create 97
135 let rec eval_query_tree tree start q =
139 Hashtbl.find table_query_tree q
144 | Dom -> all_nodes tree
145 | Tag (t,k) -> element_by_tag tree t k
146 | Axis (a,q1) -> let ls = eval_query_tree tree start q1 in
148 | Binop (op,q1,q2)-> begin
149 let ls1 = eval_query_tree tree start q1 in
150 let ls2 = eval_query_tree tree start q2 in
152 | Union -> union_list tree ls1 ls2
153 | Inter -> inter_list tree ls1 ls2
154 | Diff -> diff_list tree ls1 ls2
157 let res = List.sort (Table.compare_node tree) res in
158 Hashtbl.add table_query_tree q res;
159 compteur := !compteur + (List.length res);
163 debug tree q resultat;