(* 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 . *) (** 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 "") (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 "" 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 = " >>#; #<< >>#; #<< >>#; #<< debug output - MLstate (c) 2009 >>#; #<< >>#; #<< >>#; #<< >>#; #<< >>#; #<< >>#; #<< >>#; #<< " >>#; #<< let uib = Printf.sprintf "%s" >>#; #<< let cont = uib "back to contents" let ppred = uib "pred" let nnext = uib "next" >>#; #<< let href = Printf.sprintf "%s" >>#; #<< let name = Printf.sprintf "%s" >>#; #<< let hh i s = Printf.sprintf "%s" i s i >>#; #<< let _end = " >>#; #<< >>#; #<< " >>#; #<< 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 "
  • %s %s %s %s
    " (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 "
  • " in >>#; #<< let link = FBuffer.addln link (Printf.sprintf "
  • %s
  • " (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)))^"" 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 "

    Debug Tracer Interface for %s version %s

    " libname libversion; >>#; #<< Printf.sprintf "

    Date of this diagnosis : %s

    \n" (now ()); >>#; #<< "\n"; >>#; #<< name 0 (hh 4 "contents :"); >>#; #<< FBuffer.contents link; >>#; #<< "\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