My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1open Syndic_common.XML
2open Syndic_common.Util
3module XML = Syndic_xml
4module Error = Syndic_error
5
6type error' =
7 [ `Line of string
8 | `Column of string
9 | `Text of string
10 | `Element of string
11 | `Parent of string
12 | `Value of string ]
13
14type error
15type warning
16type 'a kind = Error | Warning
17
18let error = Error
19let warning = Warning
20
21type 'a t =
22 { kind: 'a kind (** Error or warning. *)
23 ; line: int
24 (** Within the source code of the validated document, refers to the
25 line where the error was detected. *)
26 ; column: int
27 (** Within the source code of the validated document, refers to the
28 line where the column was detected. *)
29 ; text: string (** The actual error message. *)
30 ; element: string
31 (** Element in the feed where the message was triggered. *)
32 ; parent: string (** In the feed, parent of the element. *)
33 ; value: string
34 (** If applicable the value of the element, attribute or content which
35 triggered the message. *) }
36
37let feed_url = Uri.of_string "http://validator.w3.org/feed/check.cgi"
38
39let url d =
40 let q = [("output", ["soap12"])] in
41 let q =
42 match d with
43 | `Data data -> ("rawdata", [data]) :: q
44 | `Uri uri -> [("url", [Uri.to_string uri])]
45 in
46 Uri.with_query feed_url q
47
48let make_error ~kind ~pos:_ (l : [< error'] list) =
49 let line =
50 match find (function `Line _ -> true | _ -> false) l with
51 | Some (`Line line) -> ( try int_of_string line with _ -> 0 )
52 | _ -> 0
53 in
54 let column =
55 match find (function `Column _ -> true | _ -> false) l with
56 | Some (`Column column) -> ( try int_of_string column with _ -> 0 )
57 | _ -> 0
58 in
59 let text =
60 match find (function `Text _ -> true | _ -> false) l with
61 | Some (`Text text) -> text
62 | _ -> ""
63 in
64 let element =
65 match find (function `Element _ -> true | _ -> false) l with
66 | Some (`Element element) -> element
67 | _ -> ""
68 in
69 let parent =
70 match find (function `Parent _ -> true | _ -> false) l with
71 | Some (`Parent parent) -> parent
72 | _ -> ""
73 in
74 let value =
75 match find (function `Value _ -> true | _ -> false) l with
76 | Some (`Value value) -> value
77 | _ -> ""
78 in
79 ({kind; line; column; text; element; parent; value} : _ t)
80
81let error_data_producer =
82 [ ("line", dummy_of_xml ~ctor:(fun ~xmlbase:_ a -> `Line a))
83 ; ("column", dummy_of_xml ~ctor:(fun ~xmlbase:_ a -> `Column a))
84 ; ("text", dummy_of_xml ~ctor:(fun ~xmlbase:_ a -> `Text a))
85 ; ("element", dummy_of_xml ~ctor:(fun ~xmlbase:_ a -> `Element a))
86 ; ("parent", dummy_of_xml ~ctor:(fun ~xmlbase:_ a -> `Parent a))
87 ; ("value", dummy_of_xml ~ctor:(fun ~xmlbase:_ a -> `Value a)) ]
88
89let error_of_xml ~kind =
90 generate_catcher ~data_producer:error_data_producer (make_error ~kind)
91
92let make_errorlist ~pos:_ (l : _ t list) = l
93
94let errorlist_of_xml =
95 let data_producer = [("error", error_of_xml ~kind:Error)] in
96 generate_catcher ~data_producer ~xmlbase:None make_errorlist
97
98let warninglist_of_xml =
99 let data_producer = [("warning", error_of_xml ~kind:Warning)] in
100 generate_catcher ~data_producer ~xmlbase:None make_errorlist
101
102let find_errorlist l =
103 recursive_find
104 (function XML.Node (_, t, _) -> tag_is t "errorlist" | _ -> false)
105 l
106
107let find_warninglist l =
108 recursive_find
109 (function XML.Node (_, t, _) -> tag_is t "warninglist" | _ -> false)
110 l
111
112let to_error {line; column; text; _} = ((line, column), text)
113
114let parse input =
115 let _, xml = XML.of_xmlm input in
116 let err =
117 match find_errorlist xml with
118 | Some (XML.Node (p, t, d)) -> errorlist_of_xml (p, t, d)
119 | _ -> []
120 in
121 let warn =
122 match find_warninglist xml with
123 | Some (XML.Node (p, t, d)) -> warninglist_of_xml (p, t, d)
124 | _ -> []
125 in
126 (err, warn)