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 = let dom = all_nodes tree in
9 List.filter (fun c -> QNameSet.mem (Naive_tree.tag tree c) tagset ) dom
11 let rec compile_single_path p =
14 | Absolute p | Relative p -> compile_step_list (List.rev p)
16 and compile_step_list p =
19 | (a,(test,_),el) :: r ->
20 let qtree = compile_step_list r in
21 let res = Binop ( Inter,Axis (a,qtree), Tag (test) ) in
22 List.fold_left (fun acc e ->
23 Binop(Inter, acc, compile_expr e)) res el (*avant j'ai utilise une function compile_expr_list ,c'est pas genial*)
25 and compile_expr (e : Xpath.Ast.expr ) = match e with
26 | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
27 let qtree = compile_expr e0 in
28 Binop (Diff , Dom, qtree)
30 | Binop (e1,op,e2) -> let qtree1 = compile_expr e1 in
31 let qtree2 = compile_expr e2 in
34 | Or -> Binop (Union , qtree1,qtree2)
35 | And -> Binop (Inter ,qtree1,qtree2)
36 | _ -> failwith "Unknown operator"
38 | Path p -> compile_path_rev p
39 | _ -> failwith "Unknown expression"
41 and compile_path_rev p =
44 | [p] -> compile_single_path_rev p
45 | p::r -> List.fold_left (fun acc p -> Binop (Union , acc, compile_single_path_rev p) ) (compile_single_path_rev p) r
47 and compile_single_path_rev p =
49 | Absolute p | Relative p -> compile_step_list_rev p (*(List.rev p)*)
51 and compile_step_list_rev p = match p with
52 | [] -> Dom (*assert false*) (*on fait rien , mais comment signifer ???*)
53 | (a,(test,_),el) :: r ->
54 let qtree = compile_step_list_rev r in
55 let res = Binop (Inter , qtree, Tag(test)) in
56 let qtree2 = List.fold_left (fun acc e ->
57 Binop(Inter, acc, compile_expr e)) res el in
58 let a_rev = axis_rev a in
66 | Attribute -> assert false
69 if not b then (Ancestor false)
70 else (Ancestor true) (* true = descendant-or-self, false = descendant *)
71 | FollowingSibling -> PrecedingSibling
74 if not b then (Descendant false)
75 else (Descendant true) (* true = ancestor-or-self, false = ancestor *)
76 | PrecedingSibling -> FollowingSibling
77 | Preceding -> Following
78 | Following -> Preceding
81 let compile_xpath p = match p with
83 | [p] -> compile_single_path p
84 | p::r -> List.fold_left (fun acc p -> Binop (Union , acc, compile_single_path p) ) (compile_single_path p) r
86 let comp_node t n1 n2 = (Naive_tree.preorder t n1) < (Naive_tree.preorder t n2)
89 let rec union_list t l1 l2 =
93 | h1::ll1, h2::ll2 -> if (comp_node t h2 h1) then h2 :: (union_list t l1 ll2)
94 else if (comp_node t h1 h2) then h1::(union_list t ll1 l2)
95 else h1 ::(union_list t ll1 ll2)
97 let rec inter_list t l1 l2 =
101 | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then inter_list t ll1 l2
102 else if (comp_node t h2 h1) then inter_list t l1 ll2
103 else h1 :: (inter_list t ll1 ll2)
105 let rec diff_list t l1 l2 =
109 | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then h1::(diff_list t ll1 l2)
110 else if (comp_node t h2 h1) then h2 :: (diff_list t l1 ll2)
111 else diff_list t ll1 ll2
114 let do_debug = ref false
117 if !do_debug then begin
118 Format.fprintf Format.std_formatter "Evaluation de: ";
119 print_query_tree Format.std_formatter q;
120 Format.fprintf Format.std_formatter "\nResultat: %i"
122 Format.pp_print_flush Format.std_formatter ();
123 print_node_list tree l;
124 Format.fprintf Format.std_formatter "\n----------------\n";
125 Format.pp_print_flush Format.std_formatter ();
128 let table_query_tree = Hashtbl.create 97
131 let rec eval_query_tree tree start q =
135 Hashtbl.find table_query_tree q
140 | Dom -> all_nodes tree
141 | Tag t -> element_by_tag tree t
142 | Axis (a,q1) -> let ls = eval_query_tree tree start q1 in
144 | Binop (op,q1,q2)-> begin
145 let ls1 = eval_query_tree tree start q1 in
146 let ls2 = eval_query_tree tree start q2 in
148 | Union -> union_list tree ls1 ls2
149 | Inter -> inter_list tree ls1 ls2
150 | Diff -> diff_list tree ls1 ls2
153 Hashtbl.add table_query_tree q res;
154 compteur := !compteur + (List.length res);
158 debug tree q resultat;