My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(* XML *)
2
3module XML = struct
4 include Syndic_xml
5
6 type node = pos * tag * t list
7
8 let xmlbase_tag = (Xmlm.ns_xml, "base")
9
10 let xmlbase_of_attr ~xmlbase attr =
11 try
12 let new_base = List.assoc xmlbase_tag attr in
13 Some (Syndic_xml.resolve ~xmlbase (Uri.of_string new_base))
14 with Not_found -> xmlbase
15
16 let generate_catcher ?(namespaces = [""]) ?(attr_producer = [])
17 ?(data_producer = []) ?leaf_producer maker =
18 let in_namespaces ((prefix, _), _) = List.mem prefix namespaces in
19 let get_attr_name (((_prefix, name), _) : Xmlm.attribute) = name in
20 let get_attr_value ((_, value) : Xmlm.attribute) = value in
21 let get_tag_name (((_prefix, name), _) : tag) = name in
22 let get_attrs ((_, attrs) : tag) = attrs in
23 let get_producer name map =
24 try Some (List.assoc name map) with _ -> None
25 in
26 let rec catch_attr ~xmlbase acc pos = function
27 | attr :: r -> (
28 match get_producer (get_attr_name attr) attr_producer with
29 | Some f when in_namespaces attr ->
30 let acc = f ~xmlbase (get_attr_value attr) :: acc in
31 catch_attr ~xmlbase acc pos r
32 | _ -> catch_attr ~xmlbase acc pos r )
33 | [] -> acc
34 in
35 let rec catch_datas ~xmlbase acc = function
36 | Node (pos, tag, datas) :: r -> (
37 match get_producer (get_tag_name tag) data_producer with
38 | Some f when in_namespaces tag ->
39 let acc = f ~xmlbase (pos, tag, datas) :: acc in
40 catch_datas ~xmlbase acc r
41 | _ -> catch_datas ~xmlbase acc r )
42 | Data (pos, str) :: r -> (
43 match leaf_producer with
44 | Some f -> catch_datas ~xmlbase (f ~xmlbase pos str :: acc) r
45 | None -> catch_datas ~xmlbase acc r )
46 | [] -> acc
47 in
48 let generate ~xmlbase ((pos, tag, datas) : node) =
49 (* The spec says that "The base URI for a URI reference appearing in any
50 other attribute value, including default attribute values, is the base
51 URI of the element bearing the attribute" so get xml:base first. *)
52 let xmlbase = xmlbase_of_attr ~xmlbase (get_attrs tag) in
53 let acc = catch_attr ~xmlbase [] pos (get_attrs tag) in
54 maker ~pos (catch_datas ~xmlbase acc datas)
55 in
56 generate
57
58 let dummy_of_xml ~ctor =
59 let leaf_producer ~xmlbase _pos data = ctor ~xmlbase data in
60 let head ~pos:_ = function [] -> ctor ~xmlbase:None "" | x :: _ -> x in
61 generate_catcher ~leaf_producer head
62end
63
64(* Util *)
65
66module Util = struct
67 let find f l = try Some (List.find f l) with Not_found -> None
68
69 exception Found of XML.t
70
71 let recursive_find f root =
72 let rec aux = function
73 | [] -> None
74 | x :: _ when f x -> raise (Found x)
75 | XML.Node (_, _, x) :: r -> (
76 aux x
77 |> function
78 | Some x -> raise (Found x) (* assert false ? *) | None -> aux r )
79 | XML.Data _ :: r -> aux r
80 in
81 try aux [root] with Found x -> Some x | _ -> None
82
83 let rec filter_map l f =
84 match l with
85 | [] -> []
86 | x :: tl -> (
87 match f x with None -> filter_map tl f | Some x -> x :: filter_map tl f )
88
89 let rec take l n =
90 match l with
91 | [] -> []
92 | e :: tl -> if n > 0 then e :: take tl (n - 1) else []
93
94 let tag_is (((_prefix, name), _attrs) : XML.tag) = ( = ) name
95 let attr_is (((_prefix, name), _value) : Xmlm.attribute) = ( = ) name
96 let datas_has_leaf = List.exists (function XML.Data _ -> true | _ -> false)
97
98 let get_leaf l =
99 match find (function XML.Data _ -> true | _ -> false) l with
100 | Some (XML.Data (_, s)) -> s
101 | None -> "" (* Return empty string for empty elements instead of raising Not_found *)
102 | _ -> raise Not_found
103
104 let get_attrs ((_, attrs) : XML.tag) = attrs
105 let get_value ((_, value) : Xmlm.attribute) = value
106 let get_attr_name (((_prefix, name), _) : Xmlm.attribute) = name
107 let get_tag_name (((_prefix, name), _) : XML.tag) = name
108 let is_space c = c = ' ' || c = '\t' || c = '\n' || c = '\r'
109
110 let only_whitespace s =
111 let r = ref true in
112 let i = ref 0 and len = String.length s in
113 while !r && !i < len do
114 r := is_space s.[!i] ;
115 incr i
116 done ;
117 !r
118
119 (* Output feeds to XML *)
120
121 let add_attr name v_opt attr =
122 match v_opt with None | Some "" -> attr | Some v -> (name, v) :: attr
123
124 let add_attr_uri name v_opt attr =
125 match v_opt with None -> attr | Some v -> (name, Uri.to_string v) :: attr
126
127 let tag name = (("", name), [])
128 let dummy_pos = (0, 0)
129
130 (* Do smarter positions make sense? *)
131
132 let node_data tag content =
133 XML.Node (dummy_pos, tag, [XML.Data (dummy_pos, content)])
134
135 let node_uri tag uri = node_data tag (Uri.to_string uri)
136
137 let add_node_data tag c nodes =
138 match c with
139 | None -> nodes
140 | Some content -> node_data tag content :: nodes
141
142 let add_node_uri tag c nodes =
143 match c with
144 | None -> nodes
145 | Some uri -> node_data tag (Uri.to_string uri) :: nodes
146
147 (* Add to [nodes] those coming from mapping [f] on [els] *)
148 let add_nodes_rev_map f els nodes =
149 List.fold_left (fun nodes el -> f el :: nodes) nodes els
150
151 let add_node_option f op nodes =
152 match op with None -> nodes | Some v -> f v :: nodes
153end