OCaml HTML5 parser/serialiser based on Python's JustHTML
anil.recoil.org
1let format_text ?system_id messages =
2 let buf = Buffer.create 1024 in
3 List.iter
4 (fun msg ->
5 let loc_str =
6 match msg.Message.location with
7 | Some loc -> (
8 let sid =
9 match loc.Message.system_id with
10 | Some s -> s
11 | None -> (
12 match system_id with Some s -> s | None -> "input")
13 in
14 let col_info =
15 match (loc.end_line, loc.end_column) with
16 | Some el, Some ec when el = loc.line && ec > loc.column ->
17 Printf.sprintf "%d.%d-%d" loc.line loc.column ec
18 | Some el, Some ec when el > loc.line ->
19 Printf.sprintf "%d.%d-%d.%d" loc.line loc.column el ec
20 | _ -> Printf.sprintf "%d.%d" loc.line loc.column
21 in
22 Printf.sprintf "%s:%s" sid col_info)
23 | None -> (
24 match system_id with Some s -> s | None -> "input")
25 in
26 let severity_str = Message.severity_to_string msg.Message.severity in
27 let code_str = " [" ^ msg.Message.code ^ "]" in
28 let elem_str =
29 match msg.Message.element with
30 | Some e -> " (element: " ^ e ^ ")"
31 | None -> ""
32 in
33 let attr_str =
34 match msg.Message.attribute with
35 | Some a -> " (attribute: " ^ a ^ ")"
36 | None -> ""
37 in
38 Buffer.add_string buf
39 (Printf.sprintf "%s: %s%s: %s%s%s\n" loc_str severity_str code_str
40 msg.Message.message elem_str attr_str))
41 messages;
42 Buffer.contents buf
43
44let format_gnu ?system_id messages =
45 let buf = Buffer.create 1024 in
46 List.iter
47 (fun msg ->
48 let loc_str =
49 match msg.Message.location with
50 | Some loc -> (
51 let sid =
52 match loc.Message.system_id with
53 | Some s -> s
54 | None -> (
55 match system_id with Some s -> s | None -> "input")
56 in
57 Printf.sprintf "%s:%d:%d" sid loc.line loc.column)
58 | None -> (
59 match system_id with Some s -> s ^ ":0:0" | None -> "input:0:0")
60 in
61 let severity_str = Message.severity_to_string msg.Message.severity in
62 let code_str = " [" ^ msg.Message.code ^ "]" in
63 Buffer.add_string buf
64 (Printf.sprintf "%s: %s%s: %s\n" loc_str severity_str code_str
65 msg.Message.message))
66 messages;
67 Buffer.contents buf
68
69let message_to_json ?system_id msg =
70 let open Jsont in
71 let severity = String (Message.severity_to_string msg.Message.severity, Meta.none) in
72 let message_text = String (msg.Message.message, Meta.none) in
73 let base = [ (("type", Meta.none), severity); (("message", Meta.none), message_text) ] in
74 let with_code =
75 (("subType", Meta.none), String (msg.Message.code, Meta.none)) :: base
76 in
77 let with_location =
78 match msg.Message.location with
79 | Some loc ->
80 let line = Number (float_of_int loc.Message.line, Meta.none) in
81 let column = Number (float_of_int loc.Message.column, Meta.none) in
82 let loc_fields =
83 [ (("firstLine", Meta.none), line); (("firstColumn", Meta.none), column) ]
84 in
85 let loc_fields =
86 match loc.Message.end_line with
87 | Some el ->
88 (("lastLine", Meta.none), Number (float_of_int el, Meta.none)) :: loc_fields
89 | None -> loc_fields
90 in
91 let loc_fields =
92 match loc.Message.end_column with
93 | Some ec ->
94 (("lastColumn", Meta.none), Number (float_of_int ec, Meta.none))
95 :: loc_fields
96 | None -> loc_fields
97 in
98 let url =
99 match loc.Message.system_id with
100 | Some s -> s
101 | None -> (
102 match system_id with Some s -> s | None -> "input")
103 in
104 (("url", Meta.none), String (url, Meta.none)) :: loc_fields @ with_code
105 | None ->
106 let url =
107 match system_id with Some s -> s | None -> "input"
108 in
109 (("url", Meta.none), String (url, Meta.none)) :: with_code
110 in
111 let with_extract =
112 match msg.Message.extract with
113 | Some e -> (("extract", Meta.none), String (e, Meta.none)) :: with_location
114 | None -> with_location
115 in
116 Object (with_extract, Meta.none)
117
118let format_json ?system_id messages =
119 let open Jsont in
120 let msg_array = Array (List.map (message_to_json ?system_id) messages, Meta.none) in
121 let obj = Object ([ (("messages", Meta.none), msg_array) ], Meta.none) in
122 match Jsont_bytesrw.encode_string ~format:Minify json obj with
123 | Ok s -> s
124 | Error e -> failwith ("JSON encoding error: " ^ e)