module Internal = struct
let (|>) f x = x f
module String = struct
include StringLabels
let get_exn = get
let get s ~index = try Some (get_exn s index) with _ -> None
let sub_exn = sub
let find_index s ~char = try Some (rindex s char) with _ -> None
end
module List = ListLabels
end
open Internal
open Printf
module Metadoc = struct
include SmartPrint
let (%) = (^-^)
let s str =
let has_leading_space = String.get str ~index:0 = Some ' ' in
let has_ending_space = String.(get str ~index:(length str - 1)) = Some ' ' in
(if has_leading_space then space else empty)
% words str
% (if has_ending_space then space else empty)
let sp = space
let sf fmt = ksprintf s fmt
let i i = OCaml.int i
let f f = OCaml.float f
let n = newline
let verbatim s = string s
let exn e = s (Printexc.to_string e)
let option ~f = function
| Some o -> f o
| None -> empty
let escape c = ksprintf string "\027[%sm" c
let color c t = escape c % t % escape "0"
let bold_red t = color "1;31" t
let bold_yellow t = color "1;33" t
let bold_green t = color "1;32" t
let greyish t = color "37" t
let to_string ~line_width ~indent t =
SmartPrint.to_string line_width indent t
let to_list ~line_width ~indent t =
let res = ref [] in
let add c = res := c :: !res in
SmartPrint.to_something line_width indent
(fun c -> `Char c |> add)
(fun s -> `String s |> add)
(fun s ofs len -> `Sub_string (s, ofs, len) |> add)
t;
List.rev !res
end
module Markdown = struct
include Metadoc
let to_markdown_string ?(line_width=72) sm =
to_string ~line_width ~indent:4 sm
let new_par = n % n
let h underliner t =
let title = to_markdown_string t in
let l = String.length title in
let underline = String.make l underliner in
verbatim title % n % verbatim underline % new_par
let h1 t = h '=' t
let h2 t = h '-' t
let par t = t % new_par
let emph t = s "*" % t % s "*"
let ul_filter l =
concat (List.filter l ~f:(fun t -> t <> empty)
|> List.map ~f:(fun t -> s "- " % t % n))
% n
let ul_inner l =
indent (separate n (List.map l ~f:(fun t -> s "- " % t)))
let url u = s "<" % verbatim u % s ">"
let link t ~url = brakets t % parens (s url)
end
module type LOGGER_CONFIGURATION = sig
type ('a, 'b) result
val debug_level: unit -> int
val with_color: unit -> bool
val line_width: int
val indent: int
val print_string: string -> (unit, 'b) result
val do_nothing: unit -> (unit, 'b) result
val name: string
end
module type LOGGER = sig
type t = SmartPrint.t
type ('a, 'b) result
val empty : t
val string : string -> t
val sub_string : string -> int -> int -> t
val ( !^ ) : string -> t
val space : t
val newline : t
val append : t -> t -> t
val ( ^-^ ) : t -> t -> t
val concat_with_space : t -> t -> t
val ( ^^ ) : t -> t -> t
val words : string -> t
val lines : string -> t
val indent : t -> t
val nest : t -> t
val nest_all : t -> t
val group : t -> t
val group_all : t -> t
val parens : t -> t
val braces : t -> t
val brakets : t -> t
val angle_brakets : t -> t
val single_quotes : t -> t
val double_quotes : t -> t
val concat : t list -> t
val separate : t -> t list -> t
module OCaml :
sig
val unit : unit -> t
val bool : bool -> t
val int : int -> t
val float : float -> t
val string : string -> t
val option : ('a -> t) -> 'a option -> t
val list : ('a -> t) -> 'a list -> t
val tuple : t list -> t
end
val to_something :
int ->
int ->
(char -> unit) ->
(string -> unit) -> (string -> int -> int -> unit) -> t -> unit
val to_buffer : int -> int -> Buffer.t -> t -> unit
val to_out_channel : int -> int -> out_channel -> t -> unit
val to_stdout : int -> int -> t -> unit
val ( % ) : t -> t -> t
val s : string -> t
val sp : t
val sf : ('a, unit, string, t) format4 -> 'a
val i : int -> t
val f : float -> t
val n : t
val verbatim : string -> t
val exn : exn -> t
val option : f:('a -> t) -> 'a option -> t
val escape : string -> t
val color : string -> t -> t
val bold_red : t -> t
val bold_yellow : t -> t
val bold_green : t -> t
val greyish : t -> t
val to_string : line_width:int -> indent:int -> SmartPrint.t -> string
val to_list :
line_width:int ->
indent:int ->
SmartPrint.t ->
[> `Char of char
| `String of string
| `Sub_string of string * int * int ] list
val print :
[< `Debug of int | `Error | `Normal | `Warning ] -> t ->
(unit, 'a) result
val ( @ ) :
t ->
[< `Debug of int | `Error | `Normal | `Warning ] ->
(unit, 'a) result
val normal : [> `Normal ]
val error : [> `Error ]
val warning : [> `Warning ]
val verbose : [> `Debug of int ]
val very_verbose : [> `Debug of int ]
end
module Make_logger (P : LOGGER_CONFIGURATION) :
LOGGER with type ('a, 'b) result = ('a, 'b) P.result = struct
include Metadoc
type ('a, 'b) result = ('a, 'b) P.result
let print log_kind t =
let convert_to_string formatted =
SmartPrint.to_string P.line_width P.indent formatted in
let display formatted = convert_to_string formatted |> P.print_string in
let using_colors = P.with_color () in
let no_color t = t in
let normal_color = if using_colors then bold_green else no_color in
let error_color = if using_colors then bold_red else no_color in
let warning_color = if using_colors then bold_yellow else no_color in
let debug_color = if using_colors then greyish else no_color in
let format_log ?(color_h=no_color) ?(color_t=no_color) head t =
let colorless = head % t in
let has_newline =
String.find_index (convert_to_string colorless) ~char:'\n' <> None in
display (
color_h (brakets head)
% string " "
% (if has_newline
then color_t (n % indent t)
else color_t t)
% newline
) in
match log_kind with
| `Normal ->
format_log ~color_h:normal_color (string P.name) t
| `Error ->
format_log ~color_h:error_color (s P.name % s ": ERROR") t
| `Warning ->
format_log ~color_h:warning_color (s P.name % s ": Warning") t
| `Debug level when P.debug_level () >= level ->
format_log ~color_h:debug_color (s P.name s ": debug")
~color_t:debug_color t
| `Debug _ -> P.do_nothing ()
let (@) t kind = print kind t
let normal = `Normal
let error = `Error
let warning = `Warning
let verbose = `Debug 1
let very_verbose = `Debug 2
end