Source file advice.ml

open! Core
open! Import

type t = Symbol.t [@@deriving sexp_of]

let add =
  let advice_add =
    Funcall.Wrap.("advice-add" <: Symbol.t @-> Symbol.t @-> Symbol.t @-> return nil)
  in
  fun t ~to_function -> advice_add to_function Q.K.around t
;;

let of_function symbol = symbol

let defun_internal
  advice_name
  here
  ~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);
  advice_name
;;

let defun_around_values
  advice_name
  here
  sync_or_async
  ~docstring
  ?interactive
  ?should_profile
  f
  =
  defun_internal
    advice_name
    here
    ~docstring
    ?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 defun_around_funcall
  advice_name
  here
  ~docstring
  ?interactive
  ?(on_parse_error = On_parse_error.Allow_raise)
  ?should_profile
  funcall
  f
  =
  defun_internal
    advice_name
    here
    ~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 ->
           fun exn ->
             raise_s
               [%message
                 "Advice failed to parse its arguments"
                   ~_:(here : Source_code_position.t)
                   ~_:(exn : exn)]
         | 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 remove =
  let advice_remove =
    Funcall.Wrap.("advice-remove" <: Symbol.t @-> Symbol.t @-> return nil)
  in
  fun t ~from_function -> advice_remove from_function t
;;