Source file `ppx_debug.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
(*********************************************************************************)
(*                Xtmpl                                                          *)
(*                                                                               *)
(*    Copyright (C) 2012-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Lesser General Public           *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)

(** *)

let mkloc = Location.mkloc
let lid loc s =
  let b = Lexing.from_string s in
  mkloc (Parse.longident b) loc

let error loc msg = raise (Location.Error (Location.error ~loc msg))
let kerror loc = Printf.ksprintf (error loc)

open Ppxlib
open Ast_helper
module Location = Ppxlib_ast__Import.Location

(** Test if a case is a catchall. *)
let is_catchall case =
  let rec is_catchall_pat p = match p.ppat_desc with
    | Ppat_any | Ppat_var _ -> true
    | Ppat_alias (p, _) | Ppat_constraint (p,_) -> is_catchall_pat p
    | _ -> false
  in
  case.pc_guard = None && is_catchall_pat case.pc_lhs

class mapper =
  object (self)
    inherit Ast_traverse.map as super

    method! expression expr =
      match expr with
      | { pexp_desc=
            Pexp_extension (
              {txt="debug"; loc},
              PStr[{pstr_desc= Pstr_eval (e, _)}]);
          _
        } ->
          (
           let args = match e.pexp_desc with
             | Ast.Pexp_apply (e,args) -> e::(List.map snd args)
             | _ -> [e]
           in
           let args = List.map (fun a -> (Nolabel,a)) args in
           let module B = Ast_builder in
           let apply = B.Default.pexp_apply ~loc [%expr print] args in
           let dbg = [%expr Log.debug (fun print -> [%e apply]);] in
           let e = [%expr if !Log.debug_enabled then [%e dbg]] in
           super#expression e
          )
      | _ ->
        super#expression expr
    end

let () =
  let mapper = new mapper in
  Driver.register_transformation
    ~impl:mapper#structure
    "stk_ppx_debug"