Source file decode.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
open Decoders
open Util
type value = Ezxmlm.node
let pp fmt v = Ezxmlm.pp fmt [ v ]
type error = value Error.t
let pp_error = Error.pp pp
let string_of_error = Error.to_string pp
let pp_name fmt (ns, name) = Format.fprintf fmt "(%S, %S)" ns name
let of_dtd_nodes = function
| _dtd, [ node ] ->
Ok node
| _ ->
Error (Error.make "expected an XML document with a single root node")
let try_parse_with f x =
match f x with
| dtd, nodes ->
of_dtd_nodes (dtd, nodes)
| exception e ->
Error
(Error.tag
"Could not parse an XML document"
(Error.make (Printexc.to_string e)) )
let of_string (s : string) = try_parse_with Ezxmlm.from_string s
let of_channel (ic : in_channel) = try_parse_with Ezxmlm.from_channel ic
let of_file (file : string) =
try Util.with_file_in file of_channel with
| e ->
Error
(Error.tag "could not open file" (Error.make (Printexc.to_string e)))
type 'a decoder = (value, 'a) Decoder.t
include Decoder
include Decoder.Infix
let succeed = pure
let and_then = bind
let from_result = of_result
let tag_ns (name : Xmlm.name) : unit decoder =
fun (v : value) ->
match v with
| `El ((name', _), _) when name = name' ->
Ok ()
| `El _ ->
Error
(Error.make
(Format.asprintf "Expected a tag with name %a" pp_name name)
~context:v )
| `Data _ ->
fail "Expected a Tag" v
let tag (name : string) : unit decoder =
fun (v : value) ->
match v with
| `El (((_ns, name'), _), _) when name = name' ->
Ok ()
| `El _ ->
Error
(Error.make
(Format.asprintf "Expected a tag with name %S" name)
~context:v )
| `Data _ ->
fail "Expected a Tag" v
let any_tag_ns : Xmlm.name decoder =
fun (v : value) ->
match v with
| `El ((name, _), _) ->
Ok name
| `Data _ ->
fail "Expected a Tag" v
let any_tag : string decoder =
fun (v : value) ->
match v with
| `El (((_ns, name), _), _) ->
Ok name
| `Data _ ->
fail "Expected a Tag" v
let data : string decoder =
fun (v : value) ->
match v with `Data s -> Ok s | `El _ -> fail "Expected Data" v
let attrs_ns : Xmlm.attribute list decoder = function
| `El ((_tag, attrs), _children) ->
Ok attrs
| `Data _ as v ->
fail "Expected a Tag" v
let attr_opt_ns (name : Xmlm.name) : string option decoder =
attrs_ns
>|= My_list.find_map (fun (name', value) ->
if name = name' then Some value else None )
let attr_ns (name : Xmlm.name) : string decoder =
attr_opt_ns name
>>= function
| Some value ->
pure value
| None ->
fail (Format.asprintf "Expected an attribute named %a" pp_name name)
let attrs : (string * string) list decoder =
attrs_ns >|= My_list.map (fun ((_ns, name), value) -> (name, value))
let attr_opt (name : string) : string option decoder =
attrs
>|= My_list.find_map (fun (name', value) ->
if name = name' then Some value else None )
let attr (name : string) : string decoder =
attr_opt name
>>= function
| Some value ->
pure value
| None ->
fail (Format.asprintf "Expected an attribute named %s" name)
let pick_children (child : 'a decoder decoder) : 'a list decoder = function
| `El ((name, _attrs), els) ->
els
|> My_list.filter_mapi (fun i el ->
match child el with
| Error _ ->
None
| Ok dec ->
Some
( dec el
|> My_result.map_err
(Error.tag
(Format.asprintf "While decoding child %i" i) ) ) )
|> My_result.combine_l
|> My_result.map_err
(Error.tag_group (Format.asprintf "In tag %a" pp_name name))
| `Data _ as v ->
fail "Expected a Tag" v
let children (child : 'a decoder) : 'a list decoder = pick_children (pure child)
let decode_value decoder v = decoder v
let decode_string : 'a decoder -> string -> ('a, error) result =
fun decoder string ->
My_result.Infix.(of_string string >>= decode_value decoder)
let decode_file : 'a decoder -> string -> ('a, error) result =
fun decoder file -> My_result.Infix.(of_file file >>= decode_value decoder)