[log] print sensible backtrace and message on `Logging.die`

Summary:
Calling `Exn.backtrace` doesn't give us the current backtrace, only the one of
the latest exception raised. Change the logic of toplevel exception catching to
print the right backtrace.

Also, do not use `Format` to print from `Config` as `Logging` may have messed
with it already.

Finally, throw in some colours!

Reviewed By: jberdine

Differential Revision: D5764825

fbshipit-source-id: cd51688

infer/src/base/CommandLineOption.ml

@@ -12,7 +12,7 @@
 open! IStd
 module F = Format
 module YBU = Yojson.Basic.Util
-module L = SimpleLogging
+module L = Die
 
 let ( = ) = String.equal
 

infer/src/base/Config.ml

@@ -16,7 +16,7 @@ open! PVariant
 
 module F = Format
 module CLOpt = CommandLineOption
-module L = SimpleLogging
+module L = Die
 
 type analyzer =
   | BiAbduction
@@ -1791,29 +1791,33 @@ let post_parsing_initialization command_opt =
    -> () ) ;
   if !version <> `None || !help <> `None then exit 0 ;
   let uncaught_exception_handler exn raw_backtrace =
-    let backtrace, should_print_backtrace_default =
+    let should_print_backtrace_default =
-      match exn with
+      match exn with L.InferUserError _ -> false | _ -> true
-      | L.InferExternalError (_, bt) | L.InferInternalError (_, bt)
-       -> (bt, true)
-      | L.InferUserError (_, bt)
-       -> (bt, false)
-      | _
-       -> (Caml.Printexc.raw_backtrace_to_string raw_backtrace, true)
     in
+    let backtrace = Caml.Printexc.raw_backtrace_to_string raw_backtrace in
     let print_exception () =
+      let error prefix msg =
+        ANSITerminal.(prerr_string [Bold; Foreground Red]) prefix ;
+        ANSITerminal.(prerr_string [Bold; Foreground Red]) msg ;
+        Out_channel.newline stderr
+      in
       match exn with
       | Failure msg
-       -> F.eprintf "ERROR: %s@\n" msg
+       -> error "ERROR: " msg
-      | L.InferExternalError (msg, _)
+      | L.InferExternalError msg
-       -> F.eprintf "External Error: %s@\n" msg
+       -> error "External Error: " msg
-      | L.InferInternalError (msg, _)
+      | L.InferInternalError msg
-       -> F.eprintf "Internal Error: %s@\n" msg
+       -> error "Internal Error: " msg
-      | L.InferUserError (msg, _)
+      | L.InferUserError msg
-       -> F.eprintf "Usage Error: %s@\n" msg
+       -> error "Usage Error: " msg
       | _
-       -> F.eprintf "Uncaught error: %s@\n" (Exn.to_string exn)
+       -> error "Uncaught error: " (Exn.to_string exn)
     in
-    if should_print_backtrace_default || !developer_mode then prerr_endline backtrace ;
+    if should_print_backtrace_default || !developer_mode then (
+      Out_channel.newline stderr ;
+      ANSITerminal.(prerr_string []) "Error backtrace:" ;
+      Out_channel.newline stderr ;
+      ANSITerminal.(prerr_string [Foreground Red] backtrace) ) ;
     print_exception () ;
     exit (L.exit_code_of_exception exn)
   in

infer/src/base/Die.ml

@@ -11,24 +11,22 @@ module F = Format
 
 type error = ExternalError | InternalError | UserError
 
-exception InferExternalError of string * string
+exception InferExternalError of string
 
-exception InferInternalError of string * string
+exception InferInternalError of string
 
-exception InferUserError of string * string
+exception InferUserError of string
 
-let raise_error error msg backtrace =
+let raise_error error ~msg =
   match error with
   | ExternalError
-   -> raise (InferExternalError (msg, backtrace))
+   -> raise (InferExternalError msg)
   | InternalError
-   -> raise (InferInternalError (msg, backtrace))
+   -> raise (InferInternalError msg)
   | UserError
-   -> raise (InferUserError (msg, backtrace))
+   -> raise (InferUserError msg)
 
-let die error msg =
+let die error fmt = F.kasprintf (fun msg -> raise_error error ~msg) fmt
-  let backtrace = Exn.backtrace () in
-  F.kasprintf (fun s -> raise_error error s backtrace) msg
 
 let exit_code_of_exception = function
   | InferUserError _

infer/src/base/Die.mli

@@ -11,11 +11,11 @@ open! IStd
 
 (* WARNING: ONLY USE IF Logging IS NOT AVAILABLE TO YOU FOR SOME REASON (e.g., inside Config). *)
 
-exception InferExternalError of string * string
+exception InferExternalError of string
 
-exception InferInternalError of string * string
+exception InferInternalError of string
 
-exception InferUserError of string * string
+exception InferUserError of string
 
 (** kind of error for [die], with similar semantics as [Logging.{external,internal,user}_error] *)
 type error = ExternalError | InternalError | UserError
@@ -24,3 +24,5 @@ val exit_code_of_exception : Exn.t -> int
 
 val die : error -> ('a, Format.formatter, unit, _) format4 -> 'a
 (** Raise the corresponding exception. *)
+
+val raise_error : error -> msg:string -> 'a

infer/src/base/Logging.ml

@@ -14,7 +14,7 @@ open! IStd
 
 module F = Format
 module CLOpt = CommandLineOption
-include SimpleLogging
+include Die
 
 (* log files *)
 (* make a copy of [f] *)
@@ -260,14 +260,7 @@ let log_of_kind error fmt =
    -> log ~to_console:false internal_error_file_fmts fmt
 
 let die error msg =
-  F.kasprintf
+  F.kasprintf (fun msg -> log_of_kind error "%s@\n" msg ; raise_error error ~msg) msg
-    (fun s ->
-      (* backtraces contain line breaks, which results in lines without the [pid][error kind] prefix in the logs if printed as-is *)
-      Exn.backtrace () |> String.split ~on:'\n'
-      |> List.iter ~f:(fun line -> log_of_kind error "%s@\n" line) ;
-      log_of_kind error "%s@\n" s ;
-      die error "%s" s)
-    msg
 
 (* create new channel from the log file, and dumps the contents of the temporary log buffer there *)
 let setup_log_file () =
@@ -341,7 +334,7 @@ type print_action = print_type * Obj.t  (** data to be printed *)
 let delayed_actions = ref []
 
 (** hook for the current printer of delayed print actions *)
-let printer_hook = ref (fun _ -> SimpleLogging.(die InternalError) "uninitialized printer hook")
+let printer_hook = ref (fun _ -> Die.(die InternalError) "uninitialized printer hook")
 
 (** extend the current print log *)
 let add_print_action pact =

infer/src/base/Logging.mli

@@ -14,10 +14,10 @@ open! IStd
 
 module F = Format
 
-(* If Logging has not been set up yet, SimpleLogging can be used instead. Prefer to use the
+(* If Logging has not been set up yet, Die can be used instead. Prefer to use the
-   functions here, as they can do more logging. *)
+   functions here, as they can do more logging. These functions are documented in Die. *)
 
-include module type of SimpleLogging
+include module type of Die
 
 val environment_info : ('a, F.formatter, unit) format -> 'a
 (** log information about the environment *)

infer/src/base/Utils.ml

@@ -11,7 +11,7 @@ open! IStd
 open! PVariant
 module F = Format
 module Hashtbl = Caml.Hashtbl
-module L = SimpleLogging
+module L = Die
 
 (** initial process times *)
 let initial_times = Unix.times ()

infer/src/unit/DifferentialFiltersTests.ml

@@ -26,7 +26,7 @@ let test_file_renamings_from_json =
           ~cmp:DifferentialFilters.FileRenamings.VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY.equal exp
           (test_output test_input)
     | Raise exc
-     -> UnitUtils.assert_raises exc (fun () -> test_output test_input)
+     -> assert_raises exc (fun () -> test_output test_input)
   in
   [ ( "test_file_renamings_from_json_with_good_input"
     , "[" ^ "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"},"
@@ -44,7 +44,7 @@ let test_file_renamings_from_json =
            []) )
   ; ( "test_file_renamings_from_json_with_well_formed_but_unexpected_input"
     , "{}"
-    , Raise (Logging.InferUserError ("Expected JSON list but got '{}'", "")) )
+    , Raise (Logging.InferUserError "Expected JSON list but got '{}'") )
   ; ( "test_file_renamings_from_json_with_well_formed_but_unexpected_value"
     , "[{\"current\": 1, \"previous\": \"BBB.java\"}]"
     , Raise
@@ -52,8 +52,7 @@ let test_file_renamings_from_json =
            ( "Error parsing file renamings: \"current\" field is not a string"
            ^ "\nExpected JSON object of the following form: "
            ^ "'{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}', "
-             ^ "but instead got: '{\"current\":1,\"previous\":\"BBB.java\"}'"
+           ^ "but instead got: '{\"current\":1,\"previous\":\"BBB.java\"}'" )) )
-           , "" )) )
   ; ( "test_file_renamings_from_json_with_malformed_input"
     , "A"
     , Raise (Yojson.Json_error "Line 1, bytes 0-1:\nInvalid token 'A'") ) ]

infer/src/unit/UnitUtils.ml

@@ -1,23 +0,0 @@
-(*
- * Copyright (c) 2017 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- *)
-let erase_backtrace exn =
-  match exn with
-  | Logging.InferUserError (msg, _)
-   -> Logging.InferUserError (msg, "")
-  | Logging.InferExternalError (msg, _)
-   -> Logging.InferExternalError (msg, "")
-  | Logging.InferInternalError (msg, _)
-   -> Logging.InferInternalError (msg, "")
-  | _
-   -> exn
-
-let assert_raises ?msg exn f =
-  OUnit2.assert_raises ?msg (erase_backtrace exn) (fun () ->
-      try f ()
-      with exn -> raise (erase_backtrace exn) )

infer/src/unit/UnitUtils.mli

@@ -1,14 +0,0 @@
-(*
- * Copyright (c) 2017 - present Facebook, Inc.
- * All rights reserved.
- *
- * This source code is licensed under the BSD style license found in the
- * LICENSE file in the root directory of this source tree. An additional grant
- * of patent rights can be found in the PATENTS file in the same directory.
- *)
-
-val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit
-(** OUnit2.assert_raises checks that a function raises some exception that's exactly the same as a
-    reference exception, but some of our internal exceptions contain verbose and flaky data, eg
-    backtraces. This will normalize such known exceptions by erasing their verbose data. Use this if
-    you're suffering from OUnit2.assert_raises. *)

infer/src/unit/stacktraceTests.ml

@@ -14,8 +14,7 @@ let tests =
   let open OUnit2 in
   let empty_string_test =
     let empty_string_test_ _ =
-      UnitUtils.assert_raises (Logging.InferUserError ("Empty stack trace", "")) (fun () ->
+      assert_raises (Logging.InferUserError "Empty stack trace") (fun () -> Stacktrace.of_string "")
-          Stacktrace.of_string "" )
     in
     "empty_string" >:: empty_string_test_
   in