Skip to content
This repository
tree: b8f08373b9
Fetching contributors…

Cannot retrieve contributors at this time

file 259 lines (247 sloc) 12.059 kb
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
    | '<' -> "&lt;" | '>' -> "&gt;" | '&' -> "&amp;" | '\'' -> "&apos;" | '\"' -> "&quot;" | 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
Something went wrong with that request. Please try again.