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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
open! Core_kernel
open! Import
module Q = struct
include Q
let after_load_functions = "after-load-functions" |> Symbol.intern
and after_revert = "after-revert-hook" |> Symbol.intern
and after_save_hook = "after-save-hook" |> Symbol.intern
and before_save_hook = "before-save-hook" |> Symbol.intern
and emacs_startup_hook = "emacs-startup-hook" |> Symbol.intern
and focus_in_hook = "focus-in-hook" |> Symbol.intern
and kill_buffer_hook = "kill-buffer-hook" |> Symbol.intern
and post_command_hook = "post-command-hook" |> Symbol.intern
and window_configuration_change_hook =
"window-configuration-change-hook" |> Symbol.intern
and window_scroll_functions = "window-scroll-functions" |> Symbol.intern
end
include Hook0
module Function = struct
type 'a t =
{ symbol : Symbol.t
; hook_type : 'a Hook_type.t
}
[@@deriving sexp_of]
let defun
(type a b)
symbol
here
?docstring
?should_profile
~(hook_type : a Hook_type.t)
(returns : (unit, b) Defun.Returns.t)
(f : a -> b)
=
let handle_result = function
| Ok () -> ()
| Error err ->
message_s [%message "Error in hook" ~_:(symbol : Symbol.t) ~_:(err : Error.t)]
in
let try_with (f : unit -> b) : b =
match returns with
| Returns (_ : unit Value.Type.t) -> Or_error.try_with f |> handle_result
| Returns_deferred (_ : unit Value.Type.t) ->
let open Async in
Deferred.Or_error.try_with f ~extract_exn:true >>| handle_result
in
Defun.defun
symbol
here
?docstring
?should_profile
returns
(match hook_type with
| Normal ->
let open Defun.Let_syntax in
let%map_open () = return () in
try_with f
| Window ->
let open Defun.Let_syntax in
let%map_open () = return ()
and window = required "window" Window.t
and start = required "start" Position.t in
try_with (fun () -> f { window; start })
| File ->
let open Defun.Let_syntax in
let%map_open () = return ()
and file = required "file" string in
try_with (fun () -> f { file }))
;;
let create symbol here ?docstring ?should_profile ~hook_type returns f =
defun symbol here ?docstring ?should_profile ~hook_type returns f;
{ symbol; hook_type }
;;
let create_with_self symbol here ?docstring ~hook_type returns f =
let self = { symbol; hook_type } in
defun symbol here ?docstring ~hook_type returns (f self);
self
;;
let funcall (type a) ({ symbol; hook_type } : a t) (x : a) =
let elisp_name = symbol |> Symbol.name in
let open Funcall in
match hook_type, x with
| Normal, () -> (elisp_name <: nullary @-> return nil) ()
| Window, { window; start } ->
(elisp_name <: Window.t @-> Position.t @-> return nil) window start
| File, { file } -> (elisp_name <: Value.Type.string @-> return nil) file
;;
let symbol t = t.symbol
end
module Where = struct
type t =
| End
| Start
[@@deriving sexp_of]
end
let remove_hook =
Funcall.("remove-hook" <: Symbol.t @-> Symbol.t @-> bool @-> return nil)
;;
let remove ?(buffer_local = false) t function_ =
remove_hook (t |> symbol) (Function.symbol function_) buffer_local
;;
module Id = Unique_id.Int ()
let make_one_shot_function_symbol function_ =
Symbol.intern
(concat
[ function_ |> Function.symbol |> Symbol.name
; "-one-shot-"
; Id.create () |> Id.to_string
])
;;
let add_hook =
Funcall.("add-hook" <: Symbol.t @-> Symbol.t @-> bool @-> bool @-> return nil)
;;
let add ?(buffer_local = false) ?(one_shot = false) ?(where = Where.Start) t function_ =
let add function_ =
add_hook
(t |> symbol)
(Function.symbol function_)
(match where with
| End -> true
| Start -> false)
buffer_local
in
match one_shot with
| false -> add function_
| true ->
let hook_function_ref = ref None in
let hook_function =
Function.create
(make_one_shot_function_symbol function_)
[%here]
~hook_type:function_.hook_type
(Returns Value.Type.unit)
(fun x ->
remove t (Option.value_exn !hook_function_ref);
Function.funcall function_ x)
in
hook_function_ref := Some hook_function;
add hook_function
;;
let clear t = Current_buffer.set_value t.var []
let run =
let run_hooks = Funcall.("run-hooks" <: Symbol.t @-> return nil) in
fun t ->
let symbol = t |> symbol in
Value.Private.run_outside_async [%here] (fun () -> run_hooks symbol)
;;
let after_load = create Q.after_load_functions ~hook_type:File
let after_revert = create Q.after_revert ~hook_type:Normal
let after_save = create Q.after_save_hook ~hook_type:Normal
let before_save = create Q.before_save_hook ~hook_type:Normal
let emacs_startup = create Q.emacs_startup_hook ~hook_type:Normal
let kill_buffer = create Q.kill_buffer_hook ~hook_type:Normal
let focus_in = create Q.focus_in_hook ~hook_type:Normal
let window_configuration_change =
create Q.window_configuration_change_hook ~hook_type:Normal
;;
let window_scroll_functions = create Q.window_scroll_functions ~hook_type:Window
let post_command = create Q.post_command_hook ~hook_type:Normal
let major_mode_hook major_mode =
let mode_name = major_mode |> Major_mode.symbol |> Symbol.name in
create (mode_name ^ "-hook" |> Symbol.intern) ~hook_type:Normal
;;