Something went wrong. Try again.
forked from gbury/dolmen
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346
(* This file is free software, part of dolmen. See file "LICENSE" for more information *)
(* Type definition *)(* ************************************************************************* *)
type 'a info = { name : string; pipe : string;}
module M = Hmap.Make(struct type 'a t = 'a info end)
type t = M.ttype 'a key = 'a M.key
type report_style = | Minimal | Regular | Contextual
type source = [ | `Stdin | `File of string | `Raw of string * string]
type sink = [ | `Stdout | `File of string]
type mode = [ | `Full | `Incremental]
type 'lang input_file = { lang : 'lang option; mode : mode option; loc : Dolmen.Std.Loc.file; dir : string; source : source;}
type 'lang output_file = { lang : 'lang option; sink : sink;}
exception Error of texception Key_not_found of t * string * string
let () = Printexc.register_printer (function | Key_not_found (_st, key_name, key_pipe) -> let msg = Format.asprintf "Key %s not bound in state. \ Have you called the init function for the %s pipe/module ?" key_name key_pipe in Some msg | _ -> None )
(* Helper functions *)(* ************************************************************************* *)
let split_input = function | `Stdin -> Sys.getcwd (), `Stdin | `File f -> Filename.dirname f, `File (Filename.basename f)
let mk_file ?lang ?mode ?(loc = Dolmen.Std.Loc.mk_file "") dir source = { lang; mode; dir; source ; loc; }
(* Signatures *)(* ************************************************************************* *)
module type S = sig
type t (** The type of state *)
type 'a key (** The type of keys into the state. *)
exception Error of t (** Convenient exception. *)
exception Key_not_found of t * string * string (** Exception raised by `get` when the key is not bound. *)
val create_key : pipe:string -> string -> _ key (** create a new key *)
val get : 'a key -> t -> 'a (** get the value associated to a key.
@raises Key_not_found if the key is not bound. *)
val get_or : default:'a -> 'a key -> t -> 'a (** get the value associated to a key, or the default if the key is not bound. *)
val set : 'a key -> 'a -> t -> t (** Set the value associated to a key. *)
val update : 'a key -> ('a -> 'a) -> t -> t (** [update key f s] updates the value associated with the key [key] according to the result of [f].
@raises Key_not_found if the key is not bound. @since 0.9 *)
val update_opt : 'a key -> ('a option -> 'a option) -> t -> t (** [update_opt key f s] updates the value associated with the key [key] according to the result of [f]. The argument passed to [f] is [Some v] if the key is currently associated with value [v], and [None] if the key is not bound.
@since 0.9 *)
val warn : ?file:_ input_file -> ?loc:Dolmen.Std.Loc.full -> t -> 'a Report.Warning.t -> 'a -> t (** Emit a warning *)
val error : ?file:_ input_file -> ?loc:Dolmen.Std.Loc.full -> t -> 'a Report.Error.t -> 'a -> t (** Emit an error. *)
val debug : bool key val reports : Report.Conf.t key val report_style : report_style key val max_warn : int key val cur_warn : int key val time_limit : float key val size_limit : float key val logic_file : Logic.language input_file key val response_file : Response.language input_file key val export_file : Logic.language output_file key (* common keys *)
end
(* Key functions *)(* ************************************************************************* *)
let empty : t = M.empty
let create_key ~pipe name = let info = { name; pipe; } in M.Key.create info
let get k t = match M.find k t with | Some v -> v | None -> let info = M.Key.info k in raise (Key_not_found (t, info.name, info.pipe))
let get_or ~default k t = match M.find k t with | Some v -> v | None -> default
let set k v t = M.add k v t
let update_opt k f t = let old_value = M.find k t in match f old_value with | Some new_value -> M.add k new_value t | None -> M.rem k t
let update k f t = update_opt k (function | Some v -> Some (f v) | None -> let info = M.Key.info k in raise (Key_not_found (t, info.name, info.pipe)) ) t
(* Some common keys *)(* ************************************************************************* *)
let pipe = "state"let bt : bool key = create_key ~pipe "bt"let debug : bool key = create_key ~pipe "debug"let reports : Report.Conf.t key = create_key ~pipe "reports"let report_style : report_style key = create_key ~pipe "report_style"let max_warn : int key = create_key ~pipe "max_warn"let cur_warn : int key = create_key ~pipe "cur_warn"
let time_limit : float key = create_key ~pipe "time_limit"let size_limit : float key = create_key ~pipe "size_limit"
let logic_file : Logic.language input_file key = create_key ~pipe "logic_file"let response_file : Response.language input_file key = create_key ~pipe "response_file"let export_file : Logic.language output_file key = create_key ~pipe "output_file"
let init ?bt:(bt_value=(Printexc.backtrace_status ())) ~debug:debug_value ~report_style:report_style_value ~reports:reports_value ~max_warn:max_warn_value ?cur_warn:(cur_warn_value=0) ~time_limit:time_limit_value ~size_limit:size_limit_value ~response_file:response_file_value st = st |> set bt bt_value |> set debug debug_value |> set report_style report_style_value |> set reports reports_value |> set max_warn max_warn_value |> set cur_warn cur_warn_value |> set time_limit time_limit_value |> set size_limit size_limit_value |> set response_file response_file_value
(* State and locations *)(* ************************************************************************* *)
let loc_input ?file st (loc : Dolmen.Std.Loc.loc) = (* sanity check to avoid pp_loc trying to read and/or print too much when printing the source code snippet) *) if loc.max_line_length >= 150 || loc.stop_line - loc.start_line >= 100 then None else begin match get report_style st, (file : _ input_file option) with | _, None -> None | _, Some { source = `Stdin; _ } -> None | (Minimal | Regular), _ -> None | Contextual, Some { source = `File filename; dir; _ } -> let full_filename = Filename.concat dir filename in let input = Pp_loc.Input.file full_filename in Some input | Contextual, Some { source = `Raw (_, contents); _ } -> let input = Pp_loc.Input.string contents in Some input end
let pp_loc ?file st fmt o = match o with | None -> begin match file with | None -> () | Some file -> let loc = Dolmen.Std.Loc.loc file.loc Dolmen.Std.Loc.no_loc in Format.fprintf fmt "%a:@ " Fmt.(styled `Bold @@ styled (`Fg (`Hi `White)) Dolmen.Std.Loc.fmt) loc end | Some loc -> if Dolmen.Std.Loc.is_dummy loc then () else begin match loc_input ?file st loc with | None -> Format.fprintf fmt "%a:@ " Fmt.(styled `Bold @@ styled (`Fg (`Hi `White)) Dolmen.Std.Loc.fmt) loc | Some input -> let loc_start, loc_end = Dolmen.Std.Loc.lexing_positions loc in let locs = Pp_loc.Position.of_lexing loc_start, Pp_loc.Position.of_lexing loc_end in Format.fprintf fmt "%a:@ %a" Fmt.(styled `Bold @@ styled (`Fg (`Hi `White)) Dolmen.Std.Loc.fmt) loc (Pp_loc.pp ~max_lines:5 ~input) [locs] end
let flush st () = let aux _ = set cur_warn 0 st in let cur = get cur_warn st in let max = get max_warn st in if cur <= max then aux () else match get report_style st with | Minimal -> Format.kfprintf aux Format.err_formatter "W:%d@." (cur - max) | Regular | Contextual -> Format.kfprintf aux Format.err_formatter ("@[<v>%a @[<hov>%s@ %d@ %swarnings@]@]@.") Fmt.(styled `Bold @@ styled (`Fg (`Hi `Magenta)) string) "Warning" (if max = 0 then "Counted" else "Plus") (cur - max) (if max = 0 then "" else "additional ")
let error ?file ?loc st error payload = let st = flush st () in let loc = Dolmen.Std.Misc.opt_map loc Dolmen.Std.Loc.full_loc in let aux _ = Code.exit (Report.Error.code error) in match get report_style st with | Minimal -> Format.kfprintf aux Format.err_formatter "E:%s@." (Report.Error.mnemonic error) | Regular | Contextual -> Format.kfprintf aux Format.err_formatter ("@[<v>%a%a @[<hov>%a@]%a@]@.") (pp_loc ?file st) loc Fmt.(styled `Bold @@ styled (`Fg (`Hi `Red)) string) "Error" Report.Error.print (error, payload) Report.Error.print_hints (error, payload)
let warn ?file ?loc st warn payload = let loc = Dolmen.Std.Misc.opt_map loc Dolmen.Std.Loc.full_loc in match Report.Conf.status (get reports st) warn with | Disabled -> st | Enabled -> let aux _ = update cur_warn ((+) 1) st in if get cur_warn st >= get max_warn st then aux st else begin match get report_style st with | Minimal -> Format.kfprintf aux Format.err_formatter "W:%s@." (Report.Warning.mnemonic warn) | Regular | Contextual -> Format.kfprintf aux Format.err_formatter ("@[<v>%a%a @[<hov>%a@]%a@]@.") (pp_loc ?file st) loc Fmt.(styled `Bold @@ styled (`Fg (`Hi `Magenta)) string) "Warning" Report.Warning.print (warn, payload) Report.Warning.print_hints (warn, payload) end | Fatal -> let aux _ = Code.exit (Report.Warning.code warn) in begin match get report_style st with | Minimal -> Format.kfprintf aux Format.err_formatter "F:%s@." (Report.Warning.mnemonic warn) | Regular | Contextual -> Format.kfprintf aux Format.err_formatter ("@[<v>%a%a @[<hov>%a@]%a@]@.") (pp_loc ?file st) loc Fmt.(styled `Bold @@ styled (`Fg (`Hi `Red)) string) "Fatal Warning" Report.Warning.print (warn, payload) Report.Warning.print_hints (warn, payload) end