Source file load_history.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
open! Core_kernel
open! Import0
module Face = Face0
module Q = struct
include Q
let autoload = "autoload" |> Symbol.intern
and provide = "provide" |> Symbol.intern
and require = "require" |> Symbol.intern
end
module Current_buffer = Current_buffer0
type t = Value.t [@@deriving sexp_of]
let load_history = Var.Wrap.("load-history" <: value)
let defining_file = Funcall.("symbol-file" <: Symbol.t @-> return (nil_or string))
module Entry = struct
type t =
| Autoload of Symbol.t
| Face of Face.t
| Fun of Symbol.t
| Previously_an_autoload of Symbol.t
| Provide of Symbol.t
| Require of Symbol.t
| Var of Symbol.t
[@@deriving sexp_of]
let cons s v = Value.cons (s |> Symbol.to_value) v
let to_value = function
| Autoload s -> cons Q.autoload (s |> Symbol.to_value)
| Face f -> cons Q.defface (f |> Face.to_value)
| Fun s -> cons Q.defun (s |> Symbol.to_value)
| Previously_an_autoload s -> cons Q.t (s |> Symbol.to_value)
| Provide s -> cons Q.provide (s |> Symbol.to_value)
| Require s -> cons Q.require (s |> Symbol.to_value)
| Var s -> s |> Symbol.to_value
;;
end
module Type = struct
module T = struct
type t =
| Face
| Fun
| Var
[@@deriving compare, enumerate, hash, sexp_of]
end
include T
let type_ =
Value.Type.enum
[%sexp "load-history type"]
(module T)
(function
| Face -> Q.defface |> Symbol.to_value
| Fun -> Value.nil
| Var -> Q.defvar |> Symbol.to_value)
;;
let t = type_
let of_value_exn = Value.Type.of_value_exn type_
let to_value = Value.Type.to_value type_
end
module Key = struct
module T = struct
type t =
{ symbol_name : string
; type_ : Type.t
}
[@@deriving compare, hash, sexp_of]
end
include T
include Hashable.Make_plain (T)
let create symbol type_ = { symbol_name = Symbol.name symbol; type_ }
end
let location_by_key : Source_code_position.t Key.Table.t = Key.Table.create ()
let location_exn symbol type_ =
match Hashtbl.find location_by_key (Key.create symbol type_) with
| Some x -> x
| None ->
raise_s
[%message "don't know location of symbol" (symbol : Symbol.t) (type_ : Type.t)]
;;
let entries = ref []
let add_entry here (entry : Entry.t) =
entries := (here, entry) :: !entries;
let add symbol type_ =
Hashtbl.set location_by_key ~key:(Key.create symbol type_) ~data:here
in
match entry with
| Face face -> add (face |> Face.to_name |> Symbol.intern) Face
| Fun symbol -> add symbol Fun
| Var symbol -> add symbol Var
| _ -> ()
;;
let append = Funcall.("append" <: value @-> value @-> return value)
let update_emacs_with_entries ~chop_prefix ~in_dir =
let addition =
!entries
|> List.map ~f:(fun ((source_code_position : Source_code_position.t), entry) ->
( String.chop_prefix_exn source_code_position.pos_fname ~prefix:chop_prefix
, entry ))
|> String.Table.of_alist_multi
|> Hashtbl.to_alist
|> List.map ~f:(fun (file, entries) ->
Value.cons
(Caml.Filename.concat in_dir file |> Value.of_utf8_bytes)
(Value.list (entries |> List.map ~f:Entry.to_value)))
|> Value.list
in
entries := [];
Current_buffer.set_value
load_history
(append addition (Current_buffer.value_exn load_history))
;;