module type Level =
sig
val level : unit -> int
val set_level : int -> unit
val incr_level : unit -> unit
val decr_level : unit -> unit
end
module FLevel = functor (C: sig end) ->
struct
let r = ref 0
let level () = !r
let set_level n = r := n
let incr_level () = incr r
let decr_level () = decr r
end
module type Media =
sig
type media
val media : unit -> media
val set_media : media -> unit
val output : int -> string -> unit
end
module type Out_channel_media = Media with type media = out_channel
module FOut_channel_media = functor (C:sig end) ->
struct
type media = out_channel
let r = ref stdout
let media () = !r
let set_media t = r := t
let output level s = output_string !r s; flush !r
end
module type Log =
sig
include Level
include Media
val print : ?level: int -> string -> unit
end
module FLog =
functor (L:Level) -> functor (M:Media) ->
struct
include L
include M
let print ?(level=1) s =
if level <= L.level() then
M.output level s
else
()
end
module Debug_stderr =
struct
module M = FOut_channel_media (struct end)
module L = FLevel (struct end)
let _ = M.set_media stderr;
include FLog (L) (M)
end
module Verbose_stdout =
struct
module M = FOut_channel_media (struct end)
module L = FLevel (struct end)
let _ = M.set_media stdout;
include FLog (L) (M)
end
module type Color_media =
sig
include Media
type color
val set_colors : (int * color) list -> unit
end
type terminal_color =
| Blue
| Cyan
| Green
| Magenta
| Red
| Yellow
module FOut_channel_media_color =
functor (L:Level) ->
functor (M:Out_channel_media) ->
struct
type color = terminal_color
let r = ref []
let set_colors l = r := l
let string_of_color c =
let code =
match c with
| Blue -> 34
| Cyan -> 36
| Green -> 32
| Magenta -> 35
| Red -> 31
| Yellow -> 33
in
Printf.sprintf "[%d;1m" code
include M
let output level s =
if level <= L.level () then
(
let oc = M.media () in
let fd = Unix.descr_of_out_channel oc in
(
try
match (Unix.fstat fd).Unix.st_kind with
Unix.S_CHR ->
(
try
let color = List.assoc level !r in
Printf.fprintf oc "%s" (string_of_color color)
with
Not_found -> ()
)
| _ -> ()
with
_ -> ()
);
M.output level s
)
else
()
end
module type Log_color =
sig
include Level
include Color_media
val print : ?level: int -> string -> unit
end
module FLog_color =
functor (L:Level) -> functor (M:Color_media) ->
struct
include L
include M
let print ?(level=1) s =
if level <= L.level() then
M.output level s
else
()
end
module Debug_stderr_color =
struct
module L = FLevel (struct end)
module Med = FOut_channel_media (struct end)
module M = FOut_channel_media_color (L) (Med)
let _ = M.set_colors
[ 1, Blue ;
2, Cyan ;
3, Green ;
4, Magenta ;
5, Red ;
6, Yellow ;
]
include FLog_color (L) (M)
end
class type ['a] media =
object
method media : 'a
method set_media : 'a -> unit
method output : string -> unit
end
class ['a] log (m: 'a media) =
object(self)
val mutable level = 0
method level = level
method set_level n = level <- n
method media = m
method print ?(level=1) s =
if self#level < level then
()
else
self#media#output s
end
class out_channel_media t =
object
val mutable media = t
method media = media
method set_media t = media <- t
method output s = output_string media s
end
let stderr () = new out_channel_media stderr
let stdout () = new out_channel_media stdout
let verbose = new log (stdout ())
let debug = new log (stderr ())
class type ['a, 'color] color_media =
object
inherit ['a] media
method set_color : 'color -> unit
end
class ['a, 'color] color_log (m: ('a, 'color) color_media) =
object
inherit ['a] log (m :> 'a media) as log
val mutable colors = []
method set_colors l = colors <- l
method print ?(level=1) s =
(
try m#set_color (List.assoc level colors)
with Not_found -> ()
);
log#print ~level s
end
class color_out_channel_media oc =
object(self)
inherit out_channel_media oc as m
method private string_of_color c =
let code =
match c with
| Blue -> 34
| Cyan -> 36
| Green -> 32
| Magenta -> 35
| Red -> 31
| Yellow -> 33
in
Printf.sprintf "[%d;1m" code
method set_color c =
let oc = m#media in
let fd = Unix.descr_of_out_channel oc in
try
match (Unix.fstat fd).Unix.st_kind with
Unix.S_CHR ->
Printf.fprintf oc "%s" (self#string_of_color c)
| _ -> ()
with
_ -> ()
end
let color_stderr () = new color_out_channel_media Pervasives.stderr
let color_stdout () = new color_out_channel_media Pervasives.stdout
let color_verbose = new color_log (color_stdout ())
let color_debug =
let o = new color_log (color_stderr ()) in
o#set_colors
[ 1, Blue ;
2, Cyan ;
3, Green ;
4, Magenta ;
5, Red ;
6, Yellow ;
] ;
o