package dolmen_loop

  1. Overview
  2. Docs

Source file state.ml

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
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333

(* This file is free software, part of dolmen. See file "LICENSE" for more information *)

(* Type definition *)
(* ************************************************************************* *)

module M = Dolmen.Std.Hmap.Make(struct
    type t = int
    let compare (a: int) (b: int) = compare a b
  end)

type t = M.t

type 'a key = {
  id : int;
  name : string;
  pipe : string;
  inj : 'a Dolmen.Std.Hmap.injection;
}

type report_style =
  | Minimal
  | Regular
  | Contextual

type source = [
  | `Stdin
  | `File of string
  | `Raw of string * string
]

type mode = [
  | `Full
  | `Incremental
]

type 'lang file = {
  lang    : 'lang option;
  mode    : mode option;
  loc     : Dolmen.Std.Loc.file;
  dir     : string;
  source  : source;
}

exception Error of t
exception 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:_ file ->
    ?loc:Dolmen.Std.Loc.full ->
    t -> 'a Report.Warning.t -> 'a -> t
  (** Emit a warning *)

  val error :
    ?file:_ 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 file key
  val response_file : Response.language file key
  (* common keys *)

end

(* Key functions *)
(* ************************************************************************* *)

let empty : t = M.empty

let key_counter = ref 0
let create_key ~pipe name =
  incr key_counter;
  { id = !key_counter; pipe; name;
    inj = Dolmen.Std.Hmap.create_inj ();}

let get k t =
  match M.get ~inj:k.inj k.id t with
  | Some v -> v
  | None -> raise (Key_not_found (t, k.name, k.pipe))

let get_or ~default k t =
  match M.get ~inj:k.inj k.id t with
  | Some v -> v
  | None -> default

let set k v t =
  M.add ~inj:k.inj k.id v t

let update_opt k f t =
  M.update ~inj:k.inj k.id f t

let update k f t =
  update_opt k (function
    | None -> raise (Key_not_found (t, k.name, k.pipe))
    | Some v -> Some (f v)) t

let key_name { name; _ } = name

(* 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 file key = create_key ~pipe "logic_file"
let response_file : Response.language file key = create_key ~pipe "response_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 : _ 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
OCaml

Innovation. Community. Security.