Source file advice.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
open! Core_kernel
open! Import

let advice_add =
  Funcall.("advice-add" <: Symbol.t @-> Symbol.t @-> Symbol.t @-> return nil)
;;

let add_predefined_function advice_name ~for_function =
  advice_add for_function Q.K.around advice_name
;;

let add_internal
      advice_name
      here
      ~for_function
      ?docstring
      ?interactive
      ?should_profile
      sync_or_async
      f
  =
  Defun.defun
    advice_name
    here
    ?docstring
    ?interactive
    ?should_profile
    (Defun.Returns.returns sync_or_async Value.Type.value)
    (let open Defun.Let_syntax in
     let%map_open () = return ()
     and inner = required "inner" value
     and rest = rest "rest" value in
     f inner rest);
  add_predefined_function advice_name ~for_function
;;

let around_values
      advice_name
      here
      sync_or_async
      ?docstring
      ~for_function
      ?interactive
      ?should_profile
      f
  =
  add_internal
    advice_name
    here
    ?docstring
    ~for_function
    ?interactive
    ?should_profile
    sync_or_async
    (fun inner rest -> f (Value.funcallN ?should_profile inner) rest)
;;

module On_parse_error = struct
  type t =
    | Allow_raise
    | Call_inner_function
  [@@deriving sexp_of]
end

let around_funcall
      advice_name
      here
      ?docstring
      ~for_function
      ?interactive
      ?(on_parse_error = On_parse_error.Allow_raise)
      ?should_profile
      funcall
      f
  =
  add_internal
    advice_name
    here
    ~for_function
    ?docstring
    ?interactive
    ?should_profile
    Sync
    (fun inner rest ->
       Funcall.Private.apply
         funcall
         (f (Funcall.Private.wrap_unrolled funcall inner))
         rest
         ~on_parse_error:
           (match (on_parse_error : On_parse_error.t) with
            | Allow_raise -> raise
            | Call_inner_function ->
              fun exn ->
                Echo_area.inhibit_messages Sync (fun () ->
                  message_s
                    [%message
                      "Ignoring advice that failed to parse its arguments."
                        ~_:(here : Source_code_position.t)
                        ~_:(exn : exn)]);
                Value.funcallN inner rest))
;;

let advice_remove = Funcall.("advice-remove" <: Symbol.t @-> Symbol.t @-> return nil)
let remove advice_name ~for_function = advice_remove for_function advice_name