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 mk_node q = {desc = q; id = -1; hash = -1}
15 let rec compile_single_path p =
18 | Absolute p | Relative p -> compile_step_list (List.rev p)
20 and compile_step_list p =
23 | (a,(test,kind),el) :: r ->
24 let qtree = compile_step_list r in
25 let res = mk_node ( Binop ( Inter,mk_node( Axis (a,qtree)),mk_node (Tag (test,kind) )) ) in
26 List.fold_left (fun acc e ->
27 mk_node (Binop(Inter, acc, compile_expr e))) res el
29 and compile_expr (e : Xpath.Ast.expr ) = match e with
30 | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
31 let qtree = compile_expr e0 in
32 mk_node (Binop (Diff , mk_node (Dom), qtree))
34 | Binop (e1,op,e2) -> let qtree1 = compile_expr e1 in
35 let qtree2 = compile_expr e2 in
38 | Or -> mk_node (Binop (Union , qtree1,qtree2))
39 | And -> mk_node (Binop (Inter ,qtree1,qtree2))
40 | _ -> failwith "Unknown operator"
42 | Path p -> compile_path_rev p
43 | _ -> failwith "Unknown expression"
45 and compile_path_rev p =
48 | [p] -> compile_single_path_rev p
49 | p::r -> List.fold_left (fun acc p -> mk_node (Binop (Union , acc, compile_single_path_rev p)) ) (compile_single_path_rev p) r
51 and compile_single_path_rev p =
53 | Absolute p | Relative p -> compile_step_list_rev p
55 and compile_step_list_rev p = match p with
57 | (a,(test,kind),el) :: r ->
58 let qtree = compile_step_list_rev r in
59 let res = mk_node (Binop (Inter , qtree,mk_node (Tag(test,kind)))) in
60 let qtree2 = List.fold_left (fun acc e ->
61 mk_node (Binop(Inter, acc, compile_expr e))) res el in
62 let a_rev = axis_rev a in
63 mk_node (Axis (a_rev , qtree2))
73 if not b then (Ancestor false)
74 else (Ancestor true) (* true = descendant-or-self, false = descendant *)
75 | FollowingSibling -> PrecedingSibling
78 if not b then (Descendant false)
79 else (Descendant true) (* true = ancestor-or-self, false = ancestor *)
80 | PrecedingSibling -> FollowingSibling
81 | Preceding -> Following
82 | Following -> Preceding
85 let compile_xpath p = match p with
87 | [p] -> compile_single_path p
88 | p::r -> List.fold_left (fun acc p -> mk_node (Binop (Union , acc, compile_single_path p) )) (compile_single_path p) r
90 let comp_node t n1 n2 = (Naive_tree.preorder t n1) < (Naive_tree.preorder t n2)
93 let rec union_list t l1 l2 =
97 | h1::ll1, h2::ll2 -> if (comp_node t h2 h1) then h2 :: (union_list t l1 ll2)
98 else if (comp_node t h1 h2) then h1::(union_list t ll1 l2)
99 else h1 ::(union_list t ll1 ll2)
101 let rec inter_list t l1 l2 =
105 | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then inter_list t ll1 l2
106 else if (comp_node t h2 h1) then inter_list t l1 ll2
107 else h1 :: (inter_list t ll1 ll2)
109 let rec diff_list t l1 l2 =
113 | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then h1::(diff_list t ll1 l2)
114 else if (comp_node t h2 h1) then h2 :: (diff_list t l1 ll2)
115 else diff_list t ll1 ll2
118 let do_debug = ref false
121 if !do_debug then begin
122 Format.fprintf Format.std_formatter "Evaluation de: ";
123 print_query_tree Format.std_formatter q;
124 Format.fprintf Format.std_formatter "\nResultat: %i\n"
126 Format.pp_print_flush Format.std_formatter ();
127 print_node_list tree l;
129 (fun n -> Format.fprintf Format.std_formatter "%i, " (Naive_tree.preorder tree n)) l;*)
130 Format.fprintf Format.std_formatter "\n----------------\n";
131 Format.pp_print_flush Format.std_formatter ();
134 let table_query_tree = Hashtbl.create 97
137 let rec eval_query_tree tree start q =
141 Hashtbl.find table_query_tree q
146 | Dom -> all_nodes tree
147 | Tag (t,k) -> element_by_tag tree t k
148 | Axis (a,q1) -> let ls = eval_query_tree tree start q1 in
150 | Binop (op,q1,q2)-> begin
151 let ls1 = eval_query_tree tree start q1 in
152 let ls2 = eval_query_tree tree start q2 in
154 | Union -> union_list tree ls1 ls2
155 | Inter -> inter_list tree ls1 ls2
156 | Diff -> diff_list tree ls1 ls2
159 let res = List.sort (Table.compare_node tree) res in
160 Hashtbl.add table_query_tree q res;
161 compteur := !compteur + (List.length res);
165 debug tree q resultat;