(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2025                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It 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 Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

type kind = Result | Feedback | Debug | Warning | Error | Failure

[@@@ warning "-32"]

let pretty_kind fmt = function
  | Result -> Format.fprintf fmt "Result"
  | Feedback -> Format.fprintf fmt "Feedback"
  | Debug -> Format.fprintf fmt "Debug"
  | Warning -> Format.fprintf fmt "Warning"
  | Error -> Format.fprintf fmt "Error"
  | Failure -> Format.fprintf fmt "Failure"

[@@@ warning "+32"]

type event = {
  evt_kind : kind ;
  evt_plugin : string ;
  evt_category : string option;
  evt_source : Filepath.position option ;
  evt_message : string ;
}

let kernel_channel_name = "kernel"
let kernel_label_name = "kernel"

(* -------------------------------------------------------------------------- *)
(* --- Exception Management                                               --- *)
(* -------------------------------------------------------------------------- *)

exception FeatureRequest of Filepath.position option * string * string
exception AbortError of string (* plug-in *)
exception AbortFatal of string (* plug-in *)

(* -------------------------------------------------------------------------- *)
(* --- Terminal Management                                                --- *)
(* -------------------------------------------------------------------------- *)

open Format

type lock =
  | Ready
  | Locked
  | DelayedLock

type terminal = {
  mutable lock : lock ;
  mutable isatty : bool ;
  mutable clean : bool ;
  mutable delayed : (terminal -> unit) list ;
  mutable output : string -> int -> int -> unit ;
  (* Same as Format.make_formatter *)
  mutable flush : unit -> unit ;
  (* Same as Format.make_formatter *)
}

let delayed_echo t =
  match t.lock with
  | Locked -> true
  | Ready | DelayedLock -> false

let is_locked t =
  match t.lock with
  | Locked | DelayedLock -> true
  | Ready -> false

let is_ready t =
  match t.lock with
  | Locked | DelayedLock -> false
  | Ready -> true

let term_clean t =
  if t.isatty && not t.clean then
    begin
      let u = "\r\027[K" in
      (* TERM escape commands:
         "\r" is carriage return ;
         "\027[K" is CSI command EL 'Erase in Line' ;
         See https://en.wikipedia.org/wiki/ANSI_escape_code
      *)
      t.output u 0 (String.length u) ;
      t.clean <- true ;
    end

let set_terminal t isatty output flush =
  begin
    (* Ensures previous terminal state is clean *)
    assert (is_ready t) ;
    term_clean t ;
    (* Now reconfigure the terminal *)
    t.isatty <- isatty ;
    t.output <- output ;
    t.flush <- flush ;
    t.clean <- true ;
  end

let stdout = {
  lock = Ready ;
  clean = true ;
  delayed = [] ;
  isatty = Unix.isatty Unix.stdout ;
  output = output_substring stdout ;
  flush =  (fun () -> flush stdout);
}

let clean () = term_clean stdout

let set_output ?(isatty=false) output flush =
  set_terminal stdout isatty output flush

(* -------------------------------------------------------------------------- *)
(* --- Locked Formatter                                                   --- *)
(* -------------------------------------------------------------------------- *)

type delayed =
  | Delayed of terminal
  | Formatter of (string -> int -> int -> unit) * (unit -> unit)

let lock_terminal t =
  begin
    if is_locked t then
      failwith "Console is already locked" ;
    term_clean t ;
    t.lock <- Locked ;
    Format.make_formatter t.output t.flush ;
  end

let unlock_terminal t fmt =
  if is_ready t then
    failwith "Console can not be unlocked" ;
  begin
    Format.pp_print_flush fmt () ;
    t.lock <- Ready ;
    List.iter
      (fun job -> job t)
      (List.rev t.delayed) ;
    t.delayed <- [] ;
  end

let print_on_output job =
  let fmt = lock_terminal stdout in
  try job fmt ; unlock_terminal stdout fmt
  with error -> unlock_terminal stdout fmt ; raise error

(* -------------------------------------------------------------------------- *)
(* --- Delayed Lock until first write                                     --- *)
(* -------------------------------------------------------------------------- *)

let delayed_terminal terminal =
  if is_locked terminal then
    failwith "Console is already locked" ;
  terminal.lock <- DelayedLock ;
  let d = ref (Delayed terminal) in
  let d_output d text k n =
    match !d with
    | Delayed t ->
      t.lock <- Locked ;
      d := Formatter( t.output , t.flush ) ;
      t.output text k n
    | Formatter(out,_) ->
      out text k n
  in
  let d_flush d () =
    match !d with
    | Delayed _ -> () (* nothing to flush yet ! *)
    | Formatter(_,flush) -> flush ()
  in
  Format.make_formatter (d_output d) (d_flush d)

let print_delayed job =
  let fmt = delayed_terminal stdout in
  try job fmt ; unlock_terminal stdout fmt
  with error -> unlock_terminal stdout fmt ; raise error

(* -------------------------------------------------------------------------- *)
(* --- Echo Line(s)                                                       --- *)
(* -------------------------------------------------------------------------- *)

(* whenever the first line of the event shall be printed along the prefix *)
let is_prefixed_event = function
  | { evt_category = None ; evt_source = None } -> true
  | _ -> false

let is_single_line text =
  try ignore (String.index_from text 0 '\n') ; false
  with Not_found -> true

let echo_firstline output text p q width =
  let t = try String.index_from text p '\n' with Not_found -> succ q in
  let n = min width (t-p) in
  output text p n

let echo_newline output =
  output "\n" 0 1

(* output indentation unless the first line is along the prefix *)
let echo_line output ~prefix text k n =
  if not prefix then output "  " 0 2 ; output text k n

let rec echo_lines ?(prefix=false) output text p q =
  if p <= q then
    let t = try String.index_from text p '\n' with Not_found -> (-1) in
    if t < 0 || t > q then
      begin
        (* incomplete, last line *)
        echo_line output ~prefix text p (q+1-p) ;
        echo_newline output ;
      end
    else
      begin
        (* complete line *)
        echo_line output ~prefix text p (t+1-p) ;
        echo_lines output text (t+1) q ;
      end

(* -------------------------------------------------------------------------- *)
(* --- Echo Event                                                         --- *)
(* -------------------------------------------------------------------------- *)

let add_source buffer = function
  | None -> ()
  | Some src ->
    (* Avoid printing ':0:' if the position is unknown. *)
    if Filepath.is_empty_pos src
    then Buffer.add_string buffer "<unknown location> "
    else begin
      Buffer.add_string buffer
        (Filepath.Normalized.to_pretty_string src.Filepath.pos_path);
      Buffer.add_string buffer ":" ;
      Buffer.add_string buffer (string_of_int src.Filepath.pos_lnum);
      Buffer.add_string buffer ": "
    end

let add_category buffer = function
  | None -> ()
  | Some a -> Buffer.add_char buffer ':' ; Buffer.add_string buffer a

let add_kind buffer = function
  | Result | Feedback | Debug -> ()
  | Error -> Buffer.add_string buffer "User Error: "
  | Warning -> Buffer.add_string buffer "Warning: "
  | Failure -> Buffer.add_string buffer "Failure: "

let echo_event evt terminal =
  begin
    term_clean terminal ;
    let buffer = Buffer.create 120 in
    Buffer.add_char buffer '[' ;
    Buffer.add_string buffer evt.evt_plugin ;
    add_category buffer evt.evt_category ;
    Buffer.add_string buffer "] " ;
    add_source buffer evt.evt_source ;
    add_kind buffer evt.evt_kind ;
    let prefix = Buffer.contents buffer in
    let header = String.length prefix in
    let text = evt.evt_message in
    let size = String.length text in
    let output = terminal.output in
    output prefix 0 header ;
    if header + size <= 80 && is_single_line text then
      begin
        output text 0 size ;
        echo_newline output ;
      end
    else
      begin
        let prefix = is_prefixed_event evt in
        if not prefix then echo_newline output ;
        echo_lines output ~prefix text 0 (String.length text - 1) ;
      end ;
    terminal.flush () ;
  end

let do_echo terminal evt =
  if delayed_echo terminal then
    terminal.delayed <- echo_event evt :: terminal.delayed
  else
    echo_event evt terminal

let do_transient terminal text p q =
  if p <= q && not (delayed_echo terminal) then
    begin
      term_clean terminal ;
      echo_firstline terminal.output text p q 80 ;
      if terminal.isatty
      then terminal.clean <- false
      else terminal.output "\n" 0 1 ;
      terminal.flush () ;
    end

(* -------------------------------------------------------------------------- *)
(* --- Source                                                             --- *)
(* -------------------------------------------------------------------------- *)

let source ~file ~line =
  Filepath.{ pos_path = file ; pos_lnum = line ; pos_bol = 0 ; pos_cnum = 0 }

let current_loc = ref (fun () -> raise Not_found)

let set_current_source fpos = current_loc := fpos

let get_current_source () = !current_loc ()

let get_source current = function
  | None -> if current then Some (!current_loc ()) else None
  | Some _ as s -> s

(* -------------------------------------------------------------------------- *)
(* --- Channels                                                           --- *)
(* -------------------------------------------------------------------------- *)

type emitter = {
  mutable listeners : (event -> unit) list ;
  mutable echo : bool ;
}

type ontty = [
  | `Message   (* Normal message (default) *)
  | `Feedback  (* Temporary visible on console, normal message otherwise *)
  | `Transient (* Temporary visible, only on console *)
  | `Silent    (* Not visible on console *)
]

let tty = ref (fun () -> false)

type channel = {
  locked_buffer : Rich_text.buffer ; (* already allocated top-level buffer *)
  mutable stack : int ;   (* number of 'stacked' buffers *)
  plugin : string ;
  emitters : emitter array ;
  terminal : terminal ;
}

type channelstate =
  | NotCreatedYet of emitter array
  | Created of channel

let nth_kind = function
  | Result   -> 0
  | Feedback -> 1
  | Debug    -> 2
  | Error    -> 3
  | Warning  -> 4
  | Failure  -> 5

let all_kinds = [| Result ; Feedback ; Debug ; Error ; Warning ; Failure |]

let () = Array.iteri
    (fun i k -> assert (i == nth_kind k))
    all_kinds

(* -------------------------------------------------------------------------- *)
(* --- Channels                                                           --- *)
(* -------------------------------------------------------------------------- *)

let all_channels : (string,channelstate) Hashtbl.t = Hashtbl.create 31
let default_emitters =
  Array.map (fun _ -> { listeners=[] ; echo=true })
    all_kinds

let new_emitters () =
  Array.map (fun e -> { listeners = e.listeners ; echo = e.echo })
    default_emitters

let get_emitters plugin =
  try
    match Hashtbl.find all_channels plugin with
    | NotCreatedYet e -> e
    | Created c -> c.emitters
  with Not_found ->
    let e = new_emitters () in
    Hashtbl.replace all_channels plugin (NotCreatedYet e) ; e


let new_channel plugin =
  let create_with_emitters plugin emitters =
    let c = {
      plugin = plugin ;
      stack = 0 ;
      locked_buffer = Rich_text.create () ;
      emitters = emitters ;
      terminal = stdout ;
    } in
    Hashtbl.replace all_channels plugin (Created c) ; c
  in
  try
    match Hashtbl.find all_channels plugin with
    | Created c -> c
    | NotCreatedYet ems -> create_with_emitters plugin ems
  with Not_found ->
    let ems = new_emitters () in
    create_with_emitters plugin ems

(* -------------------------------------------------------------------------- *)
(* --- Already emitted messages                                           --- *)
(* -------------------------------------------------------------------------- *)

let check_not_yet = ref (fun _evt -> false)

(* -------------------------------------------------------------------------- *)
(* --- Listeners                                                          --- *)
(* -------------------------------------------------------------------------- *)

let do_fire e f = f e

let iter_kind ?kind f ems =
  match kind with
  | None -> Array.iter f ems
  | Some ks -> List.iter (fun k -> f ems.(nth_kind k)) ks

let iter_plugin ?plugin ?kind f =
  match plugin with
  | None ->
    Hashtbl.iter
      (fun _ s ->
         match s with
         | Created c -> iter_kind ?kind f c.emitters
         | NotCreatedYet ems -> iter_kind ?kind f ems)
      all_channels ;
    iter_kind ?kind f default_emitters
  | Some p ->
    iter_kind ?kind f (get_emitters p)

let add_listener ?plugin ?kind demon =
  iter_plugin ?plugin ?kind (fun em -> em.listeners <- em.listeners @ [demon])

let set_echo ?plugin ?kind echo =
  iter_plugin ?plugin ?kind (fun em -> em.echo <- echo)

let notify e =
  let es = get_emitters e.evt_plugin in
  List.iter (fun f -> f e) es.(nth_kind e.evt_kind).listeners

(* -------------------------------------------------------------------------- *)
(* --- Generic Log Routine                                                --- *)
(* -------------------------------------------------------------------------- *)

let open_buffer c =
  if c.stack > 0 then
    ( c.stack <- succ c.stack ; Rich_text.create () )
  else
    ( c.stack <- 1 ; c.locked_buffer )

let close_buffer c =
  if c.stack > 1 then
    c.stack <- pred c.stack
  else
    Rich_text.shrink c.locked_buffer

let logtransient channel text =
  let buffer = open_buffer channel in
  Rich_text.kprintf
    (fun fmt ->
       try
         Format.pp_print_newline fmt () ;
         Format.pp_print_flush fmt () ;
         let p,q = Rich_text.trim buffer in
         do_transient channel.terminal (Rich_text.contents buffer) p q ;
         close_buffer channel
       with e ->
         close_buffer channel ;
         raise e
    ) buffer text

let locked_listeners = ref false

let logwithfinal finally channel
    ?(fire=true)    (* fire channel listeners *)
    ?emitwith       (* additional emitter *)
    ?(once=false)   (* log and emit only once *)
    ?(echo=true)    (* echo on terminal *)
    ?(current=false) (* use current source as default *)
    ?source (* source location *)
    ?(kind=Feedback) (* message kind *)
    ?category (* message category *)
    ?append (* additional text *)
    text =
  let buffer = open_buffer channel in
  Format.pp_open_vbox (Rich_text.formatter buffer) 0 ;
  Rich_text.kprintf
    (fun fmt ->
       try
         (match append with None -> () | Some k -> k fmt) ;
         Format.pp_close_box fmt () ;
         Format.pp_print_newline fmt () ;
         Format.pp_print_flush fmt () ;
         let p,q = Rich_text.trim buffer in
         let output =
           if p <= q then
             let source = get_source current source in
             let message = Rich_text.range buffer p q in
             let event = {
               evt_kind = kind ;
               evt_plugin = channel.plugin ;
               evt_category = category ;
               evt_message = message ;
               evt_source = source ;
             } in
             if not once || !check_not_yet event then
               begin
                 let e = channel.emitters.(nth_kind kind) in
                 if echo && e.echo then
                   do_echo channel.terminal event ;
                 Option.iter (do_fire event) emitwith;
                 if fire && not !locked_listeners then
                   begin
                     try
                       locked_listeners := true ;
                       List.iter (do_fire event) e.listeners ;
                       locked_listeners := false ;
                     with exn ->
                       locked_listeners := false ;
                       raise exn
                   end ;
                 Some event
               end
             else None
           else None
         in
         close_buffer channel ;
         finally output
       with e ->
         close_buffer channel ;
         raise e
    ) buffer text

let finally_unit _ = ()
let finally_raise e _ = raise e
let finally_false _ = false

let cmdline_error_occurred = Extlib.mk_fun "Log.cmdline_error_occurred"
let cmdline_at_error_exit = Extlib.mk_fun "Log.at_error_exit"

type deferred_exn =
  | DNo_exn
  | DWarn_as_error of event
  | DError of event
  | DFatal of event

let deferred_exn = ref DNo_exn

let unreported_error = "##unreported-error##"

(* we keep track of at most one deferred exception, ordered by seriousness
   (internal error > user error > warning-as-error). the rationale is that
   an internal error might cause subsequent errors or warning, but the reverse
   is not true: an deferred user error must not lead to an internal error.
   Should that ever happen, at the very least the code should be modified to
   directly [abort] instead of merely logging an [error].
*)
let update_deferred_exn exn =
  match !deferred_exn, exn with
  | DNo_exn, _ -> deferred_exn := exn
  | DWarn_as_error _, DWarn_as_error _ -> ()
  | DWarn_as_error _, _ -> deferred_exn := exn
  | DError _, (DNo_exn | DWarn_as_error _ | DError _) -> ()
  | DError _, DFatal _ -> deferred_exn := exn
  | DFatal _, _ -> ()

let warn_event_as_error event = update_deferred_exn (DWarn_as_error event)

let deferred_raise ~fatal event msg =
  (* reset deferred flag. *)
  let () = deferred_exn := DNo_exn in
  let channel = new_channel event.evt_plugin in
  let pp_pos fmt pos =
    if Filepath.is_empty_pos pos
    then Format.fprintf fmt "<unknown location> "
    else Format.fprintf fmt "%a: " Filepath.pp_pos pos
  in
  let pp_pos_opt = Pretty_utils.pp_opt pp_pos in
  let print_event fmt =
    Format.fprintf fmt "@\n%a%s" pp_pos_opt event.evt_source event.evt_message
  in
  let append = Some print_event in
  let exn =
    if fatal then AbortFatal event.evt_plugin
    else AbortError event.evt_plugin
  in
  let finally = finally_raise exn in
  (* change the kind to avoid re-appending 'Error' to the message *)
  logwithfinal finally channel ?append ~kind:Result msg

let treat_deferred_error () =
  match !deferred_exn with
  | DNo_exn -> ()
  | DWarn_as_error event ->
    let wkey =
      match event.evt_category with
      | None -> ""
      | Some s when s = unreported_error -> ""
      | Some s -> s
    in
    deferred_raise ~fatal:false { event with evt_kind = Error }
      "Deferred error: warning as error %s:" wkey
  | DError event ->
    deferred_raise ~fatal:false event
      "Deferred error message was emitted during execution:"
  | DFatal event ->
    deferred_raise ~fatal:true event
      "Deferred internal error message was emitted during execution:"

(* -------------------------------------------------------------------------- *)
(* --- Messages Interface                                                 --- *)
(* -------------------------------------------------------------------------- *)

type 'a pretty_printer =
  ?current:bool -> ?source:Filepath.position ->
  ?emitwith:(event -> unit) -> ?echo:bool -> ?once:bool ->
  ?append:(Format.formatter -> unit) ->
  ('a,formatter,unit) format -> 'a

type ('a,'b) pretty_aborter =
  ?current:bool -> ?source:Filepath.position -> ?echo:bool ->
  ?append:(Format.formatter -> unit) ->
  ('a,formatter,unit,'b) format4 -> 'a

let log_channel channel
    ?(kind=Result)
    ?current ?source
    ?emitwith ?echo ?once
    ?append
    text =
  logwithfinal finally_unit channel ?once ?echo ?emitwith ?current ?source
    ~kind ?append text

let echo e =
  try
    match Hashtbl.find all_channels e.evt_plugin with
    | NotCreatedYet _ -> raise Not_found
    | Created c -> do_echo c.terminal e
  with Not_found ->
    let msg =
      Format.sprintf "[unknown channel %s]:%s"
        e.evt_plugin e.evt_message
    in failwith msg

(* ------------------------------------------------------------------------- *)
(* --- Plug-in Interface                                                 --- *)
(* ------------------------------------------------------------------------- *)

module Category_trie =
struct
  (* No Datatype at this level for dependencies reasons *)
  module String_map = Map.Make(String)

  type 'a t =
    | Node of 'a option * 'a t String_map.t

  let empty = Node (None, String_map.empty)

  let rec add_structure l t =
    match l with
    | [] -> t
    | x :: l ->
      let Node (info, map) = t in
      let binding =
        try String_map.find x map
        with Not_found -> Node (info, String_map.empty)
      in
      let res = add_structure l binding in
      Node (info, String_map.add x res map)

  let rec add_info l ?merge info (Node (old_info, map)) =
    match l with
    | [] ->
      let rec aux map =
        String_map.map
          (function Node(old_info, map) ->
             let new_info =
               match old_info, merge with
               | None, _ | _, None -> Some info
               | Some old_info, Some merge -> Some (merge old_info info)
             in
             Node (new_info, aux map)) map
      in
      Node (Some info, aux map)
    | x :: l ->
      let binding = String_map.find x map in
      let res = add_info l info binding in
      Node (old_info, String_map.add x res map)

  let rec get l (Node(info, map)) =
    match l with
    | [] -> info
    | x :: l ->
      let binding = String_map.find x map in
      get l binding

  let fold f map acc =
    let rec aux suf (Node(info, map)) acc =
      let acc = f (List.rev suf) info acc in
      String_map.fold (fun s t acc -> aux (s::suf) t acc) map acc
    in aux [] map acc

  let suffixes l trie =
    let rec aux res suf l (Node(_,map)) =
      match l with
      | [] ->
        let res = (List.rev suf) :: res in
        String_map.fold (fun s t res -> aux res (s::suf) [] t) map res
      | x::l ->
        let t = String_map.find x map in
        aux res (x::suf) l t
    in
    (* Provide results in lexicographic order. *)
    List.rev (aux [] [] l trie)
end

let rec split_joker = function
  | [] -> []
  | ["*"] -> []
  | ""::w -> split_joker w
  | a::w -> a::split_joker w

let split_category s = split_joker (String.split_on_char ':' s)

let evt_category = function
  | { evt_category = None } -> []
  | { evt_category = Some s } -> split_category s

(* a is a sub-category of b *)
let rec is_subcategory a b = match a,b with
  | _,[] -> true
  | [],_ -> false
  | a1::aw , b1::bw -> a1 = b1 && is_subcategory aw bw

let merge_category l =
  match l with
  | [] -> "*"
  | [ s ] -> s
  | hd :: tl ->
    let b = Buffer.create 15 in
    Buffer.add_string b hd;
    List.iter (fun s -> Buffer.add_char b ':'; Buffer.add_string b s) tl;
    Buffer.contents b

type warn_status =
  | Winactive
  | Wfeedback_once
  | Wfeedback
  | Wonce
  | Wactive
  | Werror_once
  | Werror
  | Wabort

let pp_warn_status fmt s =
  let s =
    match s with
    | Winactive -> "inactive"
    | Wfeedback_once -> "feedback,once"
    | Wfeedback -> "feedback"
    | Wonce -> "once"
    | Wactive ->   "active"
    | Werror_once -> "error,once"
    | Werror -> "error"
    | Wabort -> "abort"
  in
  Format.pp_print_string fmt s

let merge_status old_status new_status =
  match old_status, new_status with
  | Winactive, Wactive -> Wactive
  | Winactive, Wonce -> Wonce
  | Winactive, _ -> Winactive
  | _ -> new_status

module type Messages =
sig

  type category

  type warn_category

  val verbose_atleast: int -> bool
  val debug_atleast: int -> bool

  val printf : ?level:int -> ?dkey:category ->
    ?current:bool -> ?source:Filepath.position ->
    ?append:(Format.formatter -> unit) ->
    ?header:(Format.formatter -> unit) ->
    ('a,formatter,unit) format -> 'a

  val result  : ?level:int -> ?dkey:category -> 'a pretty_printer
  val has_tty : unit -> bool
  val feedback: ?ontty:ontty -> ?level:int -> ?dkey:category -> 'a pretty_printer
  val debug   : ?level:int -> ?dkey:category -> 'a pretty_printer
  val warning : ?wkey: warn_category -> 'a pretty_printer
  val error   : 'a pretty_printer
  val abort   : ('a,'b) pretty_aborter
  val failure : 'a pretty_printer
  val fatal   : ('a,'b) pretty_aborter
  val verify  : bool -> ('a,bool) pretty_aborter

  val not_yet_implemented : ?current:bool -> ?source:Filepath.position ->
    ('a,formatter,unit,'b) format4 -> 'a
  val deprecated : string -> now:string -> ('a -> 'b) -> 'a -> 'b

  val with_result  : (event option -> 'b) -> ('a,'b) pretty_aborter
  val with_warning : (event option -> 'b) -> ('a,'b) pretty_aborter
  val with_error   : (event option -> 'b) -> ('a,'b) pretty_aborter
  val with_failure : (event option -> 'b) -> ('a,'b) pretty_aborter

  val log : ?kind:kind -> ?verbose:int -> ?debug:int -> 'a pretty_printer
  val logwith : (event option -> 'b) ->
    ?wkey: warn_category -> ?emitwith:(event -> unit) -> ?once:bool -> ('a,'b) pretty_aborter

  val register : kind -> (event -> unit) -> unit (** Very local listener. *)

  val register_tag_handlers : (string -> string) * (string -> string) -> unit

  val register_category: ?help:string -> string -> category

  val pp_category: Format.formatter -> category -> unit

  val pp_all_categories: unit -> unit

  val dkey_name: category -> string

  val is_registered_category: string -> bool

  val get_category: string -> category option
  val get_all_categories: unit -> category list

  val add_debug_keys: category -> unit
  val del_debug_keys: category -> unit
  val get_debug_keys: unit -> category list

  val is_debug_key_enabled: category -> bool

  val register_warn_category: ?help:string -> string -> warn_category

  val is_warn_category: string -> bool

  val pp_warn_category: Format.formatter -> warn_category -> unit

  val pp_all_warn_categories_status: unit -> unit

  val wkey_name: warn_category -> string

  val get_warn_category: string -> warn_category option

  val get_all_warn_categories: unit -> warn_category list

  val get_all_warn_categories_status: unit -> (warn_category * warn_status) list

  val set_warn_status: warn_category -> warn_status -> unit

  val get_warn_status: warn_category -> warn_status

end

module Register
    (P : sig
       val channel : string
       val label : string
       val verbose_atleast : int -> bool
       val debug_atleast : int -> bool
     end) =
struct

  include P

  type category = string

  type warn_category = string

  let categories = ref Category_trie.empty

  let categories_help : ((string, string) Hashtbl.t) = Hashtbl.create 5

  let () = Hashtbl.add categories_help "*" "All categories"

  let register_category ?(help="No description provided") (s:string) =
    let l = split_category s in
    categories := Category_trie.add_structure l !categories;
    Hashtbl.replace categories_help s help;
    s

  let pp_category fmt (cat: category) = Format.pp_print_string fmt cat

  let get_category_help (cat: category) =
    match Hashtbl.find_opt categories_help cat with
    | None -> "Not registered directly (see subcategory descriptions)"
    | Some help -> help

  let get_all_categories () =
    List.map merge_category (Category_trie.suffixes [] !categories)

  let is_registered_category s =
    List.mem (split_category s) (Category_trie.suffixes [] !categories)

  let get_category s =
    if is_registered_category s then Some s else None

  let not_registered s =
    failwith (s ^ " is not a registered category for " ^ label)

  let dkey_name s = s

  let wkey_name s = s

  let add_debug_keys s =
    try
      categories := Category_trie.add_info (split_category s) true !categories
    with Not_found -> not_registered s

  let del_debug_keys s =
    try
      categories := Category_trie.add_info (split_category s) false !categories
    with Not_found -> not_registered s

  let get_debug_keys () =
    let f cat info acc =
      match info with
      | None | Some false -> acc
      | Some true -> (merge_category cat) :: acc
    in
    Category_trie.fold f !categories []

  let is_debug_key_enabled (c:category) =
    let s = (c:>string) in
    match Category_trie.get (split_category s) !categories with
    | None -> false
    | Some flag -> flag
    | exception Not_found -> not_registered s

  let has_debug_key = function
    | None -> true (* No key means to be displayed each time *)
    | Some c -> is_debug_key_enabled c

  let warn_categories = ref Category_trie.empty

  let warn_categories_help : ((string, string) Hashtbl.t) = Hashtbl.create 5

  let () = Hashtbl.add warn_categories_help "*" "All warning categories"

  let register_warn_category ?(help="No description provided") s =
    let l = split_category s in
    warn_categories := Category_trie.add_structure l !warn_categories;
    Hashtbl.replace warn_categories_help s help;
    s

  let get_warn_category_help (cat: category) =
    match Hashtbl.find_opt warn_categories_help cat with
    | None -> "Not registered directly (see subcategory descriptions)"
    | Some help -> help

  let get_all_warn_categories () =
    List.map merge_category (Category_trie.suffixes [] !warn_categories)

  let get_all_warn_categories_status () =
    List.rev
      (Category_trie.fold
         (fun cat status l  ->
            (merge_category cat, Option.value ~default:Wactive status) :: l)
         !warn_categories [])

  let is_warn_category s =
    List.mem (split_category s) (Category_trie.suffixes [] !warn_categories)

  let pp_warn_category fmt s = Format.pp_print_string fmt s

  let get_warn_category s = if is_warn_category s then Some s else None

  let wnot_registered s =
    failwith (s ^ " is not a registered warning category for " ^ label)

  let set_warn_status s status =
    try
      warn_categories :=
        Category_trie.add_info
          (split_category s) ~merge:merge_status status !warn_categories
    with Not_found -> wnot_registered s

  let get_warn_status s =
    match Category_trie.get (split_category s) !warn_categories with
    | Some s -> s
    | None -> Wactive
    | exception Not_found -> wnot_registered s

  let channel = new_channel P.channel

  let internal_register_tag_handlers _c (_ope,_close) = ()
  (* BM->LOIC: I need to keep this code around to be able to handle
     marks and tags correctly.
     Do you think we can emulate all other features of Log but without
     using c.buffer at all?
     Everything but ensure_unique_newline seems feasible.
     See Design.make_slash to see a useful example.

     let start_of_line= Printf.sprintf "\n[%s] " P.label in
     let length= pred (String.length start_of_line) in
     Format.pp_set_all_formatter_output_functions c.formatter
     ~out:c.term.output
     ~flush:c.term.flush
     ~newline:(fun () -> c.term.output start_of_line 0 length)
     ~spaces:(fun _ ->  ()(*TODO:correct margin*))
     ;
     Format.pp_set_tags c.formatter true;
     Format.pp_set_mark_tags c.formatter true;
     Format.pp_set_print_tags c.formatter false;
     Format.pp_set_formatter_tag_functions c.formatter
     {(Format.pp_get_formatter_tag_functions c.formatter ())
     with
     Format.mark_open_tag = ope;
     mark_close_tag = close}
  *)

  let register_tag_handlers h =
    internal_register_tag_handlers channel h

  let to_be_log verbose debug =
    match verbose , debug with
    | 0 , 0 -> verbose_atleast 1
    | v , 0 -> verbose_atleast v
    | 0 , d -> debug_atleast d
    | v , d -> verbose_atleast v || debug_atleast d

  let log ?(kind=Result)
      ?(verbose=0) ?(debug=0)
      ?current ?source
      ?emitwith ?echo ?once
      ?append text =
    if to_be_log verbose debug then
      logwithfinal finally_unit channel ?once ?echo ?emitwith ?current ?source
        ~kind
        ?append text
    else Pretty_utils.nullprintf text

  let result
      ?(level=1) ?dkey ?current ?source
      ?emitwith ?echo ?once ?append text =
    if verbose_atleast level && has_debug_key dkey then
      logwithfinal finally_unit channel ?once ?echo ?emitwith ?current ?source
        ~kind:Result ?category:dkey ?append text
    else Pretty_utils.nullprintf text

  let transient channel = channel.terminal.isatty && !tty ()

  let has_tty () = transient channel

  let feedback
      ?(ontty=`Message)
      ?(level=1) ?dkey ?current ?source
      ?emitwith ?echo ?once ?append text =
    let mode =
      if verbose_atleast level && has_debug_key dkey
      then
        match ontty with
        | `Feedback -> if transient channel then `Transient else `Message
        | `Transient -> if transient channel then `Transient else `Silent
        | `Silent -> if transient channel then `Silent else `Message
        | `Message -> `Message
      else `Silent
    in match mode with
    | `Message ->
      logwithfinal finally_unit channel ?once ?echo ?emitwith ?current ?source
        ~kind:Feedback ?category:dkey ?append text
    | `Transient -> logtransient channel text
    | `Silent -> Pretty_utils.nullprintf text

  let should_output_debug level dkey =
    match level, dkey with
    | None, None -> debug_atleast 1
    | Some l, None -> debug_atleast l
    | None, Some _ -> has_debug_key dkey
    | Some l, Some _ -> debug_atleast l && has_debug_key dkey

  let debug
      ?level ?dkey ?current ?source
      ?emitwith ?echo ?once ?append text =
    if should_output_debug level dkey then
      logwithfinal finally_unit channel ?once ?echo ?emitwith ?current ?source
        ~kind:Debug ?category:dkey ?append text
    else
      Pretty_utils.nullprintf text

  let force_error = function
    | None ->
      { evt_kind = Failure;
        evt_plugin = channel.plugin;
        evt_category = Some unreported_error;
        evt_message = "Silent error";
        evt_source = None
      }
    | Some evt -> evt

  let finally_user_error evt =
    let evt = force_error evt in update_deferred_exn (DError evt)

  let finally_internal_error evt =
    let evt = force_error evt in update_deferred_exn (DFatal evt)

  let error
      ?current ?source
      ?emitwith ?echo ?once ?append text =
    logwithfinal
      finally_user_error channel ?once ?echo ?emitwith ?current ?source
      ~kind:Error ?append text

  let abort ?current ?source ?echo ?append text =
    logwithfinal (finally_raise (AbortError P.channel))
      channel ?echo ?current ?source
      ~kind:Error ?append text

  let failure
      ?current ?source
      ?emitwith ?echo ?once ?append text =
    logwithfinal finally_internal_error channel
      ?once ?echo ?emitwith ?current ?source ~kind:Failure ?append text

  let fatal
      ?current ?source
      ?echo ?append text =
    logwithfinal (finally_raise (AbortFatal P.channel)) channel
      ?echo ?current ?source
      ~kind:Failure ?append text

  let verify assertion
      ?current ?source
      ?echo ?append text =
    if assertion then
      Format.kfprintf (fun _ -> true) Pretty_utils.null text
    else
      logwithfinal finally_false channel ?echo ?current ?source
        ~kind:Failure ?append text

  let logwith
      finally
      ?(wkey="") ?emitwith ?once
      ?current ?source
      ?echo ?append text =
    let status = get_warn_status wkey in
    let kind =
      match status with
      | Wfeedback | Wfeedback_once -> Feedback
      | (Wactive | Werror | Wabort | Wonce | Werror_once | Winactive) ->
        Warning
    in
    if status <> Winactive && (kind <> Feedback || verbose_atleast 1)  then
      begin
        let action, once_suffix =
          match status with
          | Wabort ->
            Some (fun _ -> abort "warning %s treated as fatal error." wkey), ""
          | Werror -> Some warn_event_as_error, ""
          | Werror_once ->
            Some
              (fun evt ->
                 warn_event_as_error evt; set_warn_status wkey Winactive),
            "warn-error-once"
          | Wfeedback_once ->
            Some (fun _ -> set_warn_status wkey Winactive), "warn-feedback-once"
          | Wonce ->
            Some (fun _ -> set_warn_status wkey Winactive), "warn-once"
          | Wactive | Winactive | Wfeedback -> None, ""
        in
        let emitwith =
          match emitwith, action with
          | None, None -> None
          | Some e, None | None, Some e -> Some e
          | Some e1, Some e2 -> Some (fun evt -> e1 evt; e2 evt)
        in
        let category = if wkey = "" then None else Some wkey in
        let append_once_suffix = (fun fmt ->
            Format.fprintf fmt
              "@.(%s: no further messages from category '%s' will be emitted)"
              once_suffix wkey)
        in
        let append = if once_suffix = "" then append
          else match append with
            | None -> Some append_once_suffix
            | Some app ->
              Some (fun fmt -> app fmt; append_once_suffix fmt)
        in
        logwithfinal finally channel ?once ?echo ?emitwith ?current ?source
          ~kind ?category ?append text
      end
    else Pretty_utils.with_null (fun () -> finally None) text

  let warning
      ?wkey ?current ?source
      ?emitwith ?echo ?once ?append text =
    logwith finally_unit
      ?wkey ?current ?source ?emitwith ?echo ?once ?append text

  let with_result finally ?current ?source ?echo ?append text =
    logwithfinal finally channel
      ~kind:Result ?current ?source ?echo ?append text

  let with_warning finally ?current ?source ?echo ?append text =
    logwithfinal finally channel
      ~kind:Warning ?current ?source ?echo ?append text

  let with_error finally ?current ?source ?echo ?append text =
    logwithfinal finally channel
      ~kind:Error ?current ?source ?echo ?append text

  let with_failure finally ?current ?source ?echo ?append text =
    logwithfinal finally channel
      ~kind:Failure ?current ?source ?echo ?append text

  let register kd f =
    let em = channel.emitters.(nth_kind kd) in
    em.listeners <- em.listeners @ [f]

  let not_yet_implemented ?(current=false) ?source text =
    let buffer = Buffer.create 80 in
    let source = get_source current source in
    let finally fmt =
      Format.pp_print_flush fmt ();
      let msg = Buffer.contents buffer in
      raise (FeatureRequest(source,channel.plugin,msg)) in
    let fmt = Format.formatter_of_buffer buffer in
    Format.kfprintf finally fmt text

  let deprecated name ~now f x =
    warning ~once:true
      "call to deprecated function '%s'.\nShould use '%s' instead."
      name now ;
    f x

  let noprint _fmt = ()

  let spynewline bol output buffer start length =
    begin
      let ofs = start+length-1 in
      if 0 <= ofs && ofs < String.length buffer then
        bol := buffer.[ofs] = '\n' ;
      output buffer start length
    end

  let printf ?(level=1) ?dkey ?current ?source ?(append=noprint)
      ?header text =
    if verbose_atleast level && has_debug_key dkey then
      begin
        (* Header is a regular message *)
        let header = match header with None -> noprint | Some h -> h in
        logwithfinal finally_unit channel ~kind:Result ~fire:false ?current ?source
          ?category:dkey "%t" header ;
        let bol = ref true in
        let stdout = { stdout with output = spynewline bol stdout.output } in
        let fmt = delayed_terminal stdout in
        try
          Format.kfprintf
            begin fun fmt ->
              append fmt ;
              Format.pp_print_flush fmt () ;
              unlock_terminal stdout fmt ;
              if not !bol then Format.pp_print_newline fmt () ;
            end
            fmt text
        with error ->
          unlock_terminal stdout fmt ; raise error
      end
    else
      Pretty_utils.nullprintf text

  let pp_all_categories () =
    let l = get_all_categories () in
    let max =
      List.fold_left (fun m s -> max m (String.length s)) 0 l
    in
    let print_one_elt fmt s =
      Format.fprintf fmt "%-*s : %s" max s (get_category_help s)
    in
    (* level 0 just in case user asks to display all categories
       in an otherwise quiet run *)
    feedback ~level:0 "@[<v 2>Message categories for %s are:@;%a@]"
      label Format.(pp_print_list ~pp_sep:pp_print_cut print_one_elt) l

  let pp_all_warn_categories_status () =
    let l = get_all_warn_categories_status () in
    let (max, max_status), l =
      (* We need the length of statuses, so we convert them to strings. *)
      List.fold_left_map (fun (m, m') (s, status) ->
          let status = Format.asprintf "%a" pp_warn_status status in
          let max_s = max m (String.length s) in
          let max_status = max m' (String.length status) in
          (max_s, max_status), (s, status)
        ) (0,0) l
    in
    let print_one_elt fmt (s, status) =
      Format.fprintf fmt "%-*s : %-*s : %s" max s max_status status
        (get_warn_category_help s)
    in
    feedback ~level:0 "@[<v 2>Warning categories for %s are@;%a@]"
      label Format.(pp_print_list ~pp_sep:pp_print_cut print_one_elt) l

end