package octez-internal-libs

  1. Overview
  2. Docs
package octez-internal-libs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file ppx_irmin_internal.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
(*
 * Copyright (c) 2022 Tarides <contact@tarides.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Ppxlib

let rewriter_name = "ppx_irmin.internal"

(* Provides a PPX wrapper around the Logs library that attaches source code
   postitions to log lines via Logs' tags system.

   Input: [%log(s?).<level> <fmt_string> <args...>]
   Output: Log(s?).(<level>) (fun f -> f <fmt_string> <args...> ~tags:(...))

   (The extension node payload can also be written in the standard CPSed form,
   for instance in order to perform computation before constructing the log
   line.)
*)

module Source = struct
  type t =
    | Logs  (** default (source-less) logging functions *)
    | Log  (** referencing a "Log" module, specifying a particular source *)

  let to_string = function Logs -> "logs" | Log -> "log"
end

let level_to_function_name : Logs.level -> string = function
  | App -> "app"
  | Error -> "err"
  | Warning -> "warn"
  | Info -> "info"
  | Debug -> "debug"

let log_function ~loc (source : Source.t) (level : Logs.level) =
  let prefix = match source with Logs -> "Logs." | Log -> "Log." in
  Ast_builder.Default.evar ~loc (prefix ^ level_to_function_name level)

let tags ~loc =
  [%expr
    Logs.Tag.add Ppx_irmin_internal_lib.Source_code_position.tag __POS__
      Logs.Tag.empty]

let expansion_function source level ~loc ~path:_ payload =
  let log_fn = log_function ~loc source level in
  let open Ast_builder.Default in
  match payload with
  | [%expr fun [%p? _] -> [%e? _]] ->
      (* Payload is already in CPS-ed form: we just need to attach the tags. *)
      [%expr
        [%e log_fn] (fun f ->
            ([%e payload] : (?header:string -> (_, _, _, _) format4 -> _) -> _)
              (f ~tags:[%e tags ~loc]))]
  | _ ->
      (* The user hasn't wrapped the payload in [fun f -> ...; f ...], so we
         should attempt to do so. This requires re-interpreting top-level
         [Pexp_apply] nodes in the AST, for example:

         > [%log.debug "fmt_string" ...args]

         This parses ["fmt_string"] as a _function_, but it's going to become
         the first argument of a function [debug]. *)
      let input_args =
        match payload with
        | { pexp_desc = Pexp_constant (Pconst_string _); _ } ->
            [ (Nolabel, payload) ]
        (* Special case for ( @@ ), e.g. [%log.err "%d" @@ 1 + 2] *)
        | [%expr [%e? fmt] @@ [%e? args]] -> [ (Nolabel, fmt); (Nolabel, args) ]
        | { pexp_desc = Pexp_apply (fmt, args); _ } -> (Nolabel, fmt) :: args
        | _ -> Location.raise_errorf ~loc "%s: invalid payload" rewriter_name
      in
      let args = input_args @ [ (Labelled "tags", tags ~loc) ] in
      [%expr [%e log_fn] (fun f -> [%e pexp_apply ~loc [%expr f] args])]

let ( let* ) x f = List.concat_map f x

let rules =
  let* source = [ Source.Logs; Log ] in
  let* level = [ Logs.App; Error; Warning; Info; Debug ] in
  let extension_name =
    Format.sprintf "irmin.%s.%s" (Source.to_string source)
      (level_to_function_name level)
  in
  [
    Extension.declare extension_name Extension.Context.expression
      Ast_pattern.(single_expr_payload __)
      (expansion_function source level)
    |> Context_free.Rule.extension;
  ]

let () = Driver.register_transformation ~rules rewriter_name
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct