camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml

   1 (* camlp4r *)
   2 (****************************************************************************)
   3 (*                                                                          *)
   4 (*                              Objective Caml                              *)
   5 (*                                                                          *)
   6 (*                            INRIA Rocquencourt                            *)
   7 (*                                                                          *)
   8 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
  10 (*  the terms of the GNU Library General Public License, with the special   *)
  11 (*  exception on linking described in LICENSE at the top of the Objective   *)
  12 (*  Caml source tree.                                                       *)
  13 (*                                                                          *)
  14 (****************************************************************************)
  15
  16 (* Authors:
  17  * - Nicolas Pouillard: initial version
  18  *)
  19
  20
  21 open Camlp4;
  22
  23 module Id = struct
  24   value name    = "Camlp4ExceptionTracer";
  25   value version = "$Id$";
  26 end;
  27
  28 module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
  29   open AstFilters;
  30   open Ast;
  31
  32   value add_debug_expr e =
  33     (* let _loc = Loc.make_absolute (MLast.loc_of_expr e) in *)
  34     let _loc = Ast.loc_of_expr e in
  35     let msg = "camlp4-debug: exc: %s at " ^ Loc.to_string _loc ^ "@." in
  36     <:expr<
  37         try $e$
  38         with
  39         [ Stream.Failure | Exit as exc -> raise exc
  40         | exc -> do {
  41             if Debug.mode "exc" then
  42               Format.eprintf $`str:msg$ (Printexc.to_string exc) else ();
  43             raise exc
  44           } ] >>;
  45
  46   value rec map_match_case =
  47     fun
  48     [ <:match_case@_loc< $m1$ | $m2$ >> ->
  49         <:match_case< $map_match_case m1$ | $map_match_case m2$ >>
  50     | <:match_case@_loc< $p$ when $w$ -> $e$ >> ->
  51         <:match_case@_loc< $p$ when $w$ -> $add_debug_expr e$ >>
  52     | m -> m ];
  53
  54   value filter = object
  55     inherit Ast.map as super;
  56     method expr = fun
  57     [ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >>
  58     | x -> super#expr x ];
  59     method str_item = fun
  60     [ <:str_item< module Debug = $_$ >> as st -> st
  61     | st -> super#str_item st ];
  62   end;
  63
  64   register_str_item_filter filter#str_item;
  65
  66 end;
  67
  68 let module M = Camlp4.Register.AstFilter Id Make in ();