error.ml 3.73 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
(******************************************************************************)
(*                                                                            *)
(*                                   Menhir                                   *)
(*                                                                            *)
(*                       François Pottier, Inria Paris                        *)
(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
(*                                                                            *)
(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
(*  terms of the GNU General Public License version 2, as described in the    *)
(*  file LICENSE.                                                             *)
(*                                                                            *)
(******************************************************************************)

14 15 16 17
open Printf

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

18 19 20 21 22 23 24 25 26 27 28 29 30
(* A mechanism to turn all display (logging, warnings, errors) on and off. *)

let enabled =
  ref true

let enable () =
  enabled := true

let disable () =
  enabled := false

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

31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
(* The new OCaml type inference protocol means that Menhir is called twice, first
   with [--infer-write-query], then with [--infer-read-reply]. This means that any
   information messages or warnings issued before OCaml type inference takes place
   are duplicated, unless we do something about it. To address this issue, when
   [--infer-read-reply] is set, we disable all output until the point where we
   read the inferred [.mli] file. Then, we enable it again and continue. *)

(* An alternative idea would be to disable all output when [--infer-write-query]
   is set. However, we would then have no output at all if this command fails. *)

let () =
  Settings.(match infer with
  | IMReadReply _ ->
      disable()
  | _ ->
      ()
  )

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

51 52 53
(* Logging and log levels. *)

let log kind verbosity msg =
54
  if kind >= verbosity && !enabled then
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
    Printf.fprintf stderr "%t%!" msg

let logG =
  log Settings.logG

let logA =
  log Settings.logA

let logC =
  log Settings.logC

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

(* Errors and warnings. *)

70
let print_positions f positions =
71
  List.iter (fun position ->
72 73 74 75 76 77 78 79
    fprintf f "%s:\n" (Positions.string_of_pos position)
  ) positions

let display continuation header positions format =
  let kprintf = if !enabled then Printf.kfprintf else Printf.ikfprintf in
  kprintf continuation stderr
    ("%a" ^^ header ^^ format ^^ "\n%!")
    print_positions positions
80

81 82 83 84
let error positions format =
  display
    (fun _ -> exit 1)
    "Error: "
85
    positions format
86

87 88 89 90
let warning positions format =
  display
    (fun _ -> ())
    "Warning: "
91
    positions format
92

POTTIER Francois's avatar
POTTIER Francois committed
93 94 95 96 97 98 99
let errorp v =
  error [ Positions.position v ]

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

(* Delayed error reports -- where multiple errors can be reported at once. *)

100 101 102 103
type category =
  bool ref

let new_category () =
POTTIER Francois's avatar
POTTIER Francois committed
104 105
  ref false

106
let signal category positions format =
POTTIER Francois's avatar
POTTIER Francois committed
107
  display
108
    (fun _ -> category := true)
POTTIER Francois's avatar
POTTIER Francois committed
109 110 111
    "Error: "
    positions format

112 113
let exit_if category =
  if !category then
114 115
    exit 1

116 117 118 119 120 121 122 123 124
(* ---------------------------------------------------------------------------- *)

(* Certain warnings about the grammar can optionally be treated as errors. *)

let grammatical_error =
  new_category()

let grammar_warning pos =
  if Settings.strict then signal grammatical_error pos else warning pos