Source file buffer_local.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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
open! Core
open! Import
include Buffer_local_intf
module Current_buffer = Current_buffer0

module Q = struct
  let permanent_local = "permanent-local" |> Symbol.intern
end

type 'a t = 'a Var.t [@@deriving sexp_of]

let symbol = Var.symbol
let var (t : _ t) : _ Var.t = t

let wrap_existing ?(make_buffer_local_always = false) symbol type_ =
  (* We raise if [symbol] isn't bound.  This fits with the naming [wrap_existing symbol]
     implying that [symbol] exists.  Also, it avoids calling
     [Var.make_buffer_local_always] on an unbound variable, which would set the variable
     to nil, which is probably not desired. *)
  if not (Current_buffer.variable_is_defined symbol)
  then
    raise_s
      [%message "[Buffer_local.wrap_existing] of undefined symbol" (symbol : Symbol.t)];
  let var = Var.create symbol type_ in
  if make_buffer_local_always
  then Var.make_buffer_local_always var
  else if not (Var.is_buffer_local_always var)
  then
    raise_s
      [%message
        {|[Buffer_local.wrap_existing] on an Elisp variable that is not automatically buffer local|}
          (symbol : Symbol.t)];
  var
;;

module Wrap = struct
  let ( <: ) ?make_buffer_local_always name type_ =
    wrap_existing ?make_buffer_local_always (name |> Symbol.intern) type_
  ;;

  include (Value.Type : Value.Type.S)
end

let defvar symbol here ?docstring ~type_ ~default_value () =
  let var =
    Defvar.defvar
      symbol
      here
      ~docstring:(Option.value docstring ~default:"An Ecaml buffer-local.")
      ~type_
      ~initial_value:default_value
      ()
  in
  Var.make_buffer_local_always var;
  var
;;

let defvar_embedded
      (type a)
      symbol
      here
      ?docstring
      (module Arg : Defvar_embedded_arg with type t = a)
  =
  defvar
    symbol
    here
    ?docstring
    ~type_:
      (Value.Type.nil_or
         (Caml_embed.create_type
            (Type_equal.Id.create ~name:(Symbol.name symbol) [%sexp_of: Arg.t])))
    ~default_value:None
    ()
;;

let set_in_current_buffer t a = Current_buffer.set_value t a

let set t a buffer =
  Current_buffer.set_temporarily Sync buffer ~f:(fun () -> set_in_current_buffer t a)
;;

let set_temporarily_in_current_buffer sync_or_async t a ~f =
  Current_buffer.set_value_temporarily sync_or_async t a ~f
;;

let get_in_current_buffer t =
  match Current_buffer.value_exn t with
  | t -> t
  | exception _ ->
    raise_s
      [%message
        "buffer has strange value for variable"
          ~variable:(t : _ Var.t)
          ~buffer:(Current_buffer.get () : Buffer.t)
          ~value:(Current_buffer.symbol_value t.symbol : Value.t)]
;;

let buffer_local_value =
  Funcall.Wrap.("buffer-local-value" <: Symbol.t @-> Buffer.t @-> return value)
;;

let get t buffer =
  Value.Type.of_value_exn (var t).type_ (buffer_local_value (symbol t) buffer)
;;

let raise_buffer_has_no_value_for_variable t ~buffer =
  raise_s
    [%message
      "buffer has no value for variable" ~variable:(t : _ Var.t) (buffer : Buffer.t)]
;;

let get_in_current_buffer_exn t =
  match get_in_current_buffer t with
  | Some x -> x
  | None -> raise_buffer_has_no_value_for_variable t ~buffer:(Current_buffer.get ())
;;

let get_exn t buffer =
  match get t buffer with
  | Some x -> x
  | None -> raise_buffer_has_no_value_for_variable t ~buffer
;;

let update_exn t buffer ~f =
  Current_buffer.set_temporarily Sync buffer ~f:(fun () ->
    set_in_current_buffer t (Some (f (get_in_current_buffer_exn t))))
;;

let permanent_property = Symbol.Property.create Q.permanent_local Value.Type.bool

let set_permanent t permanent =
  Symbol.Property.put permanent_property (symbol t) permanent
;;

let is_permanent t =
  Symbol.Property.get permanent_property (symbol t) |> Option.value ~default:false
;;

module Private = struct
  let get_in_current_buffer = get_in_current_buffer
  let get_in_current_buffer_exn = get_in_current_buffer_exn
  let set_in_current_buffer = set_in_current_buffer
  let set_temporarily_in_current_buffer = set_temporarily_in_current_buffer
end