forked from alokmenghrajani/opalang
/
debugTracer.ml
259 lines (247 loc) · 11.8 KB
/
debugTracer.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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(** implementation of debugTracer : cf mli file
@author Mathieu Barbin samedi 18 avril 2009, 15:35:35 (UTC+0100) *)
let tm () = Unix.localtime (Unix.time ())
let d2 n =
let d = n / 10 and u = n mod 10 in
Printf.sprintf "%d%d" d u
let year () =
let t = Unix.localtime (Unix.time ()) in
("20"^(d2 (t.Unix.tm_year mod 100)))
let now ?time () =
let t = Unix.localtime (match time with Some t -> t | _ -> Unix.time ()) in
Printf.sprintf "%s/%s/%s - %s:%s:%s"
(d2 t.Unix.tm_mday)
(d2 (t.Unix.tm_mon + 1))
(d2 (t.Unix.tm_year mod 100))
(d2 t.Unix.tm_hour)
(d2 t.Unix.tm_min)
(d2 t.Unix.tm_sec)
let htmlescaped =
let f = function
| '<' -> "<" | '>' -> ">" | '&' -> "&" | '\'' -> "'" | '\"' -> """ | c -> String.make 1 c in
fun s ->
let len = String.length s in
(* let rec fold buf i = if i >= len then FBuffer.contents buf else fold (FBuffer.add buf (f (String.unsafe_get s i))) (succ i) in *)
(* fold (FBuffer.create 1024) 0 *)
let rec fold buf i =
if i >= len then
FBuffer.contents buf
else
let c = String.unsafe_get s i in
if c = '\027' && i + 3 < len && (String.unsafe_get s (i+1)) = '[' then
if (String.unsafe_get s (i+2)) = '0' then
fold (FBuffer.add buf "</span>") (i+4)
else
let color_type = if (String.unsafe_get s (i+2)) = '4' then "background" else "foreground" in
let color_name = Ansi.string_of_color (Ansi.uncolor (int_of_string (String.make 1 (String.unsafe_get s (i+3))))) in
fold (FBuffer.add buf (Printf.sprintf "<span class=\"%s_color_%s\">" color_type color_name)) (i+5)
else
fold (FBuffer.add buf (f c)) (i+1)
in
fold (FBuffer.create 1024) 0
#<< type data = string >>#;
#<< module Debug = >>#;
#<< struct >>#;
#<< type id = int * string >>#;
#<< type t = string * data list >>#;
#<< type tree = (id * t list) list >>#;
#<< let fresh = let t = ref (-1) in (fun s -> incr(t); (!t, s)) >>#;
#<< let compare (a, _) (b, _) = Pervasives.compare a b >>#;
#<< let create = fresh >>#;
#<< let to_string (_, s) = s >>#;
#<< let warning = fresh "warnings" >>#;
#<< let error = fresh "errors" >>#;
#<< let info = fresh "infos (verbose)" >>#;
#<< end >>#;
#<< module type DEBUGTRACER = sig val ext : string list val generate : libname:string -> libversion:string -> Debug.tree -> (string * string) list end >>#;
#<< module type SPEDEBUGTRACER = sig val ext : string val generator : libname:string -> libversion:string -> Debug.tree -> (string * string) end >>#;
#<< module EmptyTracer : DEBUGTRACER = struct let ext = [] let generate ~libname:_ ~libversion:_ _ = [] end >>#;
#<< module AddTracer (Tracer : DEBUGTRACER) (Spe : SPEDEBUGTRACER) : DEBUGTRACER = >>#;
#<< struct >>#;
#<< let ext = Spe.ext::Tracer.ext >>#;
#<< let generate ~libname ~libversion tree = (Spe.generator ~libname ~libversion tree)::(Tracer.generate ~libname ~libversion tree) >>#;
#<< end >>#;
#<< module HTMLTracer : SPEDEBUGTRACER = >>#;
#<< struct >>#;
#<< let _begin = " >>#;
#<< <html> >>#;
#<< <head> >>#;
#<< <title>debug output - MLstate (c) 2009</title> >>#;
#<< <link rel=\"stylesheet\" type=\"text/css\" href=\"/shared/debugstyle.css\" /> >>#;
#<< <link rel=\"stylesheet\" type=\"text/css\" href=\"/shared/ocaml/lib/debugstyle.css \" /> >>#;
#<< <link rel=\"stylesheet\" type=\"text/css\" href=\"/shared/ocaml/lib64/debugstyle.css \" /> >>#;
#<< <link rel=\"stylesheet\" type=\"text/css\" href=\"debugstyle.css\" /> >>#;
#<< </head> >>#;
#<< <body> >>#;
#<< " >>#;
#<< let uib = Printf.sprintf "<u><i>%s</i></u>" >>#;
#<< let cont = uib "back to contents" let ppred = uib "pred" let nnext = uib "next" >>#;
#<< let href = Printf.sprintf "<a href=\"#%d\">%s</a>" >>#;
#<< let name = Printf.sprintf "<a name=\"%d\">%s</a>" >>#;
#<< let hh i s = Printf.sprintf "<h%d>%s</h%d>" i s i >>#;
#<< let _end = " >>#;
#<< </body> >>#;
#<< </html>" >>#;
#<< let ext = "html" >>#;
#<< let labelm = let t = ref 0 in fun () -> incr(t); !t >>#;
#<< let generator ~libname ~libversion tree = >>#;
#<< let fold_item (pp, buf, link) (m, lmess) = >>#;
#<< let label = labelm () in >>#;
#<< let buf = FBuffer.addln buf (Printf.sprintf "<li>%s %s %s %s <pre>" (name label ("Module "^(String.capitalize m))) (href pp ppred) (href (succ label) nnext) (href 0 cont)) in >>#;
#<< let buf = List.fold_left (fun buf m -> FBuffer.addln buf (htmlescaped m)) buf lmess in >>#;
#<< let buf = FBuffer.addln buf "</pre></li>" in >>#;
#<< let link = FBuffer.addln link (Printf.sprintf "<li>%s</li>" (href label ("module "^(String.lowercase m)))) in >>#;
#<< label, buf, link in >>#;
#<< let fold_id (buf, link) (id, items) = >>#;
#<< let label = labelm () and idd = Debug.to_string id in >>#;
#<< let buf = FBuffer.addln buf ((name label (hh 2 (String.capitalize idd)))^"<ul>") in >>#;
#<< let link = FBuffer.addln link ((href label (String.lowercase idd))^"<ul>") in >>#;
#<< let _, buf, link = List.fold_left fold_item (pred label, buf, link) items in >>#;
#<< let buf = FBuffer.addln buf "</ul>" and link = FBuffer.addln link "</ul>" in buf, link in >>#;
#<< let tree_debug, link = List.fold_left fold_id ((FBuffer.create 1024), (FBuffer.create 1024)) tree in >>#;
#<< ext, >>#;
#<< List.fold_left (^) "" >>#;
#<< [ >>#;
#<< _begin; >>#;
#<< Printf.sprintf "<h1>Debug Tracer Interface for %s version %s</h1>" libname libversion; >>#;
#<< Printf.sprintf "<h2>Date of this diagnosis : %s</h2>\n" (now ()); >>#;
#<< "<small>\n"; >>#;
#<< name 0 (hh 4 "contents :"); >>#;
#<< FBuffer.contents link; >>#;
#<< "</small>\n"; >>#;
#<< FBuffer.contents tree_debug; >>#;
#<< _end >>#;
#<< ] >>#;
#<< end >>#;
#<< module DebugTracer : DEBUGTRACER = AddTracer(EmptyTracer)(HTMLTracer) >>#;
module type DEBUGINTERFACE =
sig
val error : ?ending:(string -> 'a) -> ?color:Ansi.color -> string -> string -> 'a
val warning : string -> ?color:Ansi.color -> string -> unit
val verbose : string -> ?color:Ansi.color -> string -> unit
val withcolor : bool -> unit
val whisper : string -> unit
#<< val debug : string -> Debug.id -> string -> unit >>#;
#<< val set_trace_prefix : string -> unit >>#;
#<< val trace : ?verbose:bool -> unit -> unit >>#;
#<< val suspend : unit -> unit >>#;
#<< val active : unit -> unit >>#;
#<< val is_active : unit -> bool >>#;
end
module type INTERFACEPARAMETER =
sig
val libname : string val version : string val quiet : unit -> bool
module DefaultColor :
sig
val error : Ansi.color
val warning : Ansi.color
val verbose : Ansi.color
val withcolor : bool
end
end
(** We got it : thanks to Mehdi who find the info on ocaml logs that ocaml has random bug with systhread *)
module MakeDebugInterface (P : INTERFACEPARAMETER)
#<< (DebugTracer : DEBUGTRACER) >>#;
=
struct
#<< (* imperative structurs of logs *) >>#;
#<< let this_id = Printf.sprintf "%s-DebugInterface" P.libname >>#;
#<< module DebugTable : >>#;
#<< sig >>#;
#<< val add : Debug.id -> string -> string -> unit >>#;
#<< val build_tree : unit -> Debug.tree >>#;
#<< val reset : unit -> unit >>#;
#<< end = >>#;
#<< struct >>#;
#<< let _table = SortHashtbl.create 10 >>#;
#<< let reset () = SortHashtbl.clear _table >>#;
#<< let init_module mess = [mess] >>#;
#<< let init_id id = SortHashtbl.add _table id (SortHashtbl.create 10) >>#;
#<< let add id mo mess = >>#;
#<< match SortHashtbl.find_opt _table id with >>#;
#<< | None -> >>#;
#<< let items = SortHashtbl.create 10 in >>#;
#<< let allmess = init_module mess in >>#;
#<< SortHashtbl.replace items mo allmess; >>#;
#<< SortHashtbl.replace _table id items >>#;
#<< | Some items -> >>#;
#<< let was = Option.default [] (SortHashtbl.find_opt items mo) in >>#;
#<< SortHashtbl.replace items mo (mess::was) >>#;
#<< let build_tree () = >>#;
#<< let fold_item mo allmess ac = (mo, List.rev allmess)::ac in >>#;
#<< let fold id items ac = >>#;
#<< let mitems = SortHashtbl.fold_right fold_item items [] in >>#;
#<< (id, mitems)::ac in >>#;
#<< SortHashtbl.fold_right fold _table [] >>#;
#<< let _ = List.iter init_id [Debug.error; Debug.warning; Debug.info] >>#;
#<< end >>#;
let _with_color = ref P.DefaultColor.withcolor
let withcolor t = _with_color := t
#<< let suspend, active, is_active = >>#;
#<< let _state = ref false in >>#;
#<< (fun () -> _state := false), (fun () -> _state := true), (fun () -> !_state) >>#;
let plot
#<< debugid >>#;
prefix _module ?(color=`black) m =
let message = Base.String.replace m "\n" "\n\t" in
#<< (if is_active () then DebugTable.add debugid _module message); >>#;
let m = Printf.sprintf "%s%s : %s" prefix _module message in
if !_with_color then Ansi.print color m else m
let warning _mo ?(color=P.DefaultColor.warning) m =
if P.quiet () then
()
else
prerr_endline (plot
#<< Debug.warning >>#;
"warning " _mo ~color m)
let verbose _mo ?(color=P.DefaultColor.verbose) m =
if P.quiet () then
()
else
prerr_endline (plot
#<< Debug.info >>#;
"" _mo ~color m)
let verboze = verbose
(* partial application for modules -- including thread denomination *)
#<< let debug mo id m = if is_active () then >>#;
#<< (* let extrath = let t = Thread.id (Thread.self ()) in if t = 0 then "" else Printf.sprintf "[th-%d]: " t in *) >>#;
#<< DebugTable.add id mo (Base.String.replace m "\n" "\n\t") >>#;
#<< let plurial, debug_ext = match DebugTracer.ext with >>#;
#<< | [t] -> "", "."^t >>#;
#<< | _::_ as l -> "s", "{"^(String.concat ", " l)^"}" >>#;
#<< | _ -> failwith (Printf.sprintf "%s has no tracer-module implemented, and that is sad !" this_id) >>#;
#<< let _prefix = ref ((String.lowercase P.libname)^"diagnostic") >>#;
#<< let set_trace_prefix s = _prefix := s >>#;
#<< let trace ?(verbose=true) () = >>#;
#<< (if verbose then verboze this_id (Printf.sprintf "for more debug info, see the file%s %s%s generated for you" plurial !_prefix debug_ext)); >>#;
#<< let tree = DebugTable.build_tree () in >>#;
#<< let debug_files = DebugTracer.generate ~libname:P.libname ~libversion:P.version tree in >>#;
#<< List.iter (fun (ext, contents) -> >>#;
#<< let filename = !_prefix^"."^ext in >>#;
#<< try let oc = open_out filename in output_string oc contents; close_out oc with >>#;
#<< _ -> verboze this_id ~color:P.DefaultColor.error (Printf.sprintf "cannot generate debug-diagnosis file %s" filename) >>#;
#<< ) debug_files >>#;
let error ?(ending=fun (_:string) -> exit 1) ?(color=P.DefaultColor.error) _mo m =
prerr_endline (plot
#<< Debug.error >>#;
"[!] " _mo ~color m); ending m
#<< let _ = at_exit (fun () -> if is_active () then trace ()) >>#;
let whisper m =
if P.quiet () then
()
else
print_endline m
end