Source file log_statement.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
open! Base
open! Import
open Ppxlib

type t =
  { format : [ `Message_with_extra_tag_parentheses | Extension_kind.Format.t ]
  ; log : [ `Global | `Instance of expression ]
  ; args : Extension_payload.t
  ; level : Optional_arg.t
  ; time : Optional_arg.t
  ; legacy_tags : Optional_arg.t
  ; loc : location
  }

let level_arg ~level_attr ~extension_name_level ~loc =
  match level_attr, extension_name_level with
  | None, None -> None
  | None, Some level -> Some (`Labelled (Extension_kind.Level.to_expression level ~loc))
  | Some expr, None -> Some (`Optional expr)
  | Some _, Some _ ->
    Some
      (`Labelled
        (Ast_builder.Default.pexp_extension
           ~loc
           (Location.error_extensionf
              ~loc
              "Cannot provide a [@@level] attribute if the extension name already has a \
               level")))
;;

let tags ~tags_attr ~loc ~log_source_position =
  let pos = Ppx_here_expander.lift_position ~loc in
  let pos_tag = [%expr [ "pos", Source_code_position.to_string [%e pos] ]] in
  let src_tags = if log_source_position then [ pos_tag ] else [] in
  let attr_tags = tags_attr |> Option.to_list in
  match src_tags @ attr_tags with
  | [] -> None
  | [ e ] -> Some (`Labelled e)
  | _ :: _ as es ->
    Some (`Labelled [%expr List.concat [%e Ast_builder.Default.elist ~loc es]])
;;

let create
  { Extension_kind.format; log_kind; level = extension_name_level }
  { Parsed_extension.args
  ; tags_attr
  ; level_attr
  ; time_attr
  ; legacy_add_extra_tag_parentheses
  }
  ~loc
  ~log_source_position
  =
  let loc = { loc with loc_ghost = true } in
  let legacy_tags = tags ~tags_attr ~loc ~log_source_position in
  let level = level_arg ~level_attr ~extension_name_level ~loc in
  let time = Optional_arg.of_optional_expr time_attr in
  let format =
    match format with
    | `Message ->
      if legacy_add_extra_tag_parentheses
      then `Message_with_extra_tag_parentheses
      else `Message
    | (`Printf | `Sexp | `String) as format -> format
  in
  let log, args =
    match log_kind with
    | `Global -> `Global, Extension_payload.Expression args
    | `Instance () ->
      Ast_pattern.(parse (pexp_apply __ __)) loc args (fun log_expr args ->
        `Instance log_expr, Extension_payload.Args args)
  in
  { format; log; args; level; time; legacy_tags; loc }
;;

let render_source ~loc =
  let open (val Ast_builder.make loc) in
  [%expr
    Ppx_log_types.Message_source.Private.code
      ~pos_fname:[%e estring loc.loc_start.pos_fname]
      ~pos_lnum:[%e eint loc.loc_start.pos_lnum]
      ~module_name:Stdlib.__MODULE__ [@merlin.hide]]
;;

let message_data format extension_payload ~loc =
  let open (val Ast_builder.make loc) in
  match format with
  | (`Message | `Message_with_extra_tag_parentheses) as format ->
    let render_with_additional_parentheses =
      match format with
      | `Message -> false
      | `Message_with_extra_tag_parentheses -> true
    in
    let payload =
      Message_sexp.of_extension_payload extension_payload ~loc
      |> Message_sexp.render ~render_with_additional_parentheses
    in
    [%expr `Structured [%e payload]]
  | `Sexp ->
    let payload =
      match Extension_payload.single_expression_or_error extension_payload ~loc with
      (* [%log.global.sexp (... : T.t)] uses [T.sexp_of_t]. *)
      | [%expr ([%e? expr] : [%t? typ])] ->
        let sexp_of_fn = Ppx_sexp_conv_expander.Sexp_of.core_type typ in
        Ast_builder.Default.eapply sexp_of_fn [ expr ] ~loc
      (* [%log.global.sexp my_expr] assumes [my_expr] is a [Sexp.t].  *)
      | expr -> expr
    in
    [%expr `Sexp [%e payload]]
  | `String ->
    let payload =
      match Extension_payload.single_expression_or_error extension_payload ~loc with
      | { pexp_desc = Pexp_constant (Pconst_string (s, loc, delimiter)); pexp_loc; _ } ->
        Ppx_string.expand
          ~config:Ppx_string.config_for_string
          ~expr_loc:pexp_loc
          ~string_loc:loc
          ~string:s
          ~delimiter
        |> Merlin_helpers.hide_expression
      | expr -> expr
    in
    [%expr `String [%e payload]]
;;

(* The below is copied from [ppx_sexp_message_expander] - see there for reasoning. *)
let wrap_in_cold_function ~loc expr =
  [%expr
    (let[@cold] ppx_log_statement () = [%e expr] in
     ppx_log_statement () [@nontail]) [@merlin.hide]]
;;

let render { format; log; args; level; time; legacy_tags; loc } =
  let open (val Ast_builder.make loc) in
  let function_name = Log_kind.log_function log ~loc in
  let make_log_statement data =
    List.filter_opt
      [ Optional_arg.to_arg level ~name:"level"
      ; Optional_arg.to_arg time ~name:"time"
      ; Optional_arg.to_arg legacy_tags ~name:"tags"
      ; Log_kind.log_arg log
      ; Some (Nolabel, data)
      ; Some (Nolabel, render_source ~loc)
      ]
    |> Ast_builder.Default.pexp_apply function_name ~loc
  in
  let log_statement =
    match format with
    | `Printf ->
      (* Printf is handled with a ksprintf, so it's separated out from [message_data]. We
         could maybe use a [sprintf] instead, but it causes format strings to have a
         slightly different type (the last type parameter which represents the return
         value of the format string is a string, not unit).

         The log statement itself returns unit, so I think unit makes sense here. *)
      pexp_apply
        [%expr Printf.ksprintf (fun str -> [%e make_log_statement [%expr `String str]])]
        (Extension_payload.to_args args)
    | (`String | `Sexp | `Message | `Message_with_extra_tag_parentheses) as format ->
      make_log_statement (message_data format args ~loc)
  in
  [%expr
    if [%e Log_kind.would_log log ~level ~loc] [@merlin.hide]
    then [%e wrap_in_cold_function log_statement ~loc]
    else [%e Log_kind.log_default log ~loc]]
;;