package ecaml

  1. Overview
  2. Docs
Library for writing Emacs plugin in OCaml

Install

Dune Dependency

Authors

Maintainers

Sources

v0.17.0.tar.gz
sha256=87e76473915e12d718096100a5c4d15d98aba6f99ecbf21814b7389e8c28bb25

doc/src/ecaml/text.ml.html

Source file text.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
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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
open! Core
open! Import

module Q = struct
  include Q

  let after_string = "after-string" |> Symbol.intern
  let background_color = "background-color" |> Symbol.intern
  let before_string = "before-string" |> Symbol.intern
  let concat = "concat" |> Symbol.intern
  let display = "display" |> Symbol.intern
  let font_lock_face = "font-lock-face" |> Symbol.intern
  let foreground_color = "foreground-color" |> Symbol.intern
  let invisible = "invisible" |> Symbol.intern
  let mouse_face = "mouse-face" |> Symbol.intern
  let propertize = "propertize" |> Symbol.intern
  let help_echo = "help-echo" |> Symbol.intern
  let kbd_help = "kbd-help" |> Symbol.intern
  let string = "string" |> Symbol.intern
end

include Value.Make_subtype (struct
  let name = "text"
  let here = [%here]
  let is_in_subtype = Value.is_string
end)

let char_code = Funcall.Wrap.("aref" <: t @-> int @-> return Char_code.t)
let set_char_code = Funcall.Wrap.("aset" <: t @-> int @-> Char_code.t @-> return nil)
let of_utf8_bytes string = string |> Value.of_utf8_bytes |> of_value_exn

let of_utf8_bytes_replacing_invalid string =
  string |> Value.of_utf8_bytes_replacing_invalid |> Tuple2.map_fst ~f:of_value_exn
;;

let to_utf8_bytes t = t |> to_value |> Value.to_utf8_bytes_exn

module Compare_as_string = struct
  module T0 = struct
    type nonrec t = t

    let compare a b = Comparable.lift [%compare: string] ~f:to_utf8_bytes a b
    let of_string = of_utf8_bytes
    let to_string = to_utf8_bytes
  end

  module T = struct
    include T0
    include Sexpable.Of_stringable (T0)
  end

  include T
  include Comparable.Make (T)
end

let length = Funcall.Wrap.("length" <: t @-> return int)
let concat ts = Symbol.funcallN Q.concat (ts : t list :> Value.t list) |> of_value_exn

let substring =
  let substring = Funcall.Wrap.("substring" <: t @-> int @-> int @-> return t) in
  fun t ~start ~end_ -> substring t start end_
;;

module Face_spec = struct
  module One = struct
    type t =
      | Attributes of Face.Attribute_and_value.t list
      | Face of Face.t
    [@@deriving sexp_of]

    let normalize = function
      | Face _ as t -> t
      | Attributes attributes ->
        Attributes (attributes |> Face.Attribute_and_value.sort_by_attribute_name)
    ;;

    let compare t1 t2 =
      match t1, t2 with
      | Face face1, Face face2 -> String.compare (Face.to_name face1) (Face.to_name face2)
      | Attributes a1, Attributes a2 ->
        List.compare Face.Attribute_and_value.compare_attribute_name a1 a2
      | Face _, _ -> -1
      | _, Face _ -> 1
    ;;

    let to_value (t : t) : Value.t =
      match t with
      | Attributes attributes ->
        Value.list
          (List.fold
             (List.rev attributes)
             ~init:[]
             ~f:(fun ac (Face.Attribute_and_value.T (attribute, value)) ->
             (attribute |> Face.Attribute.to_symbol |> Symbol.to_value)
             :: (value |> Face.Attribute.to_value attribute)
             :: ac))
      | Face face -> face |> Face.to_value
    ;;

    let raise_unexpected value =
      raise_s [%message "[Face.One.of_value_exn] got unexpected value" (value : Value.t)]
    ;;

    let of_value_exn value : t =
      match Face.of_value_exn value with
      | x -> Face x
      | exception _ ->
        if not (Value.is_cons value) then raise_unexpected value;
        let car = Value.car_exn value in
        let cdr = Value.cdr_exn value in
        if not (Value.is_cons cdr)
        then (
          (* Old style specs: [(background-color . color)] [(foreground-color . color)] *)
          let symbol = car |> Symbol.of_value_exn in
          let color = cdr |> Color.of_value_exn in
          if Symbol.equal symbol Q.foreground_color
          then Attributes [ T (Foreground, Color color) ]
          else if Symbol.equal symbol Q.background_color
          then Attributes [ T (Background, Color color) ]
          else raise_unexpected value)
        else (
          let rec loop value ac =
            if Value.is_nil value
            then Attributes (List.rev ac)
            else (
              if not (Value.is_cons value) then raise_unexpected value;
              let car = Value.car_exn value in
              let cdr = Value.cdr_exn value in
              if Value.is_cons car
              then loop cdr ((car |> Face.Attribute_and_value.of_value_exn) :: ac)
              else
                let module A = Face.Attribute.Packed in
                let (A.T attribute) = car |> A.of_value_exn in
                loop
                  (Value.cdr_exn cdr)
                  (T
                     ( attribute
                     , Value.car_exn cdr |> Face.Attribute.of_value_exn attribute )
                   :: ac))
          in
          loop value [])
    ;;
  end

  type t = One.t list [@@deriving sexp_of]

  let normalize t = t |> List.map ~f:One.normalize |> List.sort ~compare:One.compare

  let to_value t =
    match t with
    | [] -> Value.nil
    | [ one ] -> One.to_value one
    | _ -> Value.list (List.map t ~f:One.to_value)
  ;;

  let of_value_exn value =
    if Value.is_nil value
    then []
    else (
      match One.of_value_exn value with
      | one -> [ one ]
      | exception _ -> Value.to_list_exn value ~f:One.of_value_exn)
  ;;

  let of_value_exn value =
    try of_value_exn value with
    | exn ->
      raise_s
        [%message
          "[Text.Face_spec.of_value_exn] got unexpected value"
            (value : Value.t)
            (exn : exn)]
  ;;

  let type_ =
    Value.Type.create [%sexp "text-face-spec"] [%sexp_of: t] of_value_exn to_value
  ;;
end

module Display_spec = struct
  type nonrec t =
    { property : Display_property.t
    ; text : t
    }
  [@@deriving sexp_of]

  let to_value (t : t) : Value.t =
    Value.list [ Display_property.to_values t.property |> Value.list; t.text |> to_value ]
  ;;

  (* We expect values to be of the form ['((margin MARGIN) TEXT)]. *)
  let of_value_exn value : t =
    match Value.to_list_exn value ~f:Fn.id with
    | [] | [ _ ] | _ :: _ :: _ :: _ ->
      raise_s [%sexp "Display_spec: Could not convert value", (value : Value.t)]
    | [ prop; txt ] ->
      { property =
          Display_property.of_values_exn
            (Value.car_exn prop, Value.car_exn (Value.cdr_exn prop))
      ; text = txt |> of_value_exn
      }
  ;;

  let type_ =
    Value.Type.create [%sexp "text-display-spec"] [%sexp_of: t] of_value_exn to_value
  ;;
end

open struct
  let text_type = type_
end

module Property_name = struct
  type 'a t =
    { name : Symbol.t
    ; type_ : 'a Value.Type.t
    }
  [@@deriving fields ~getters]

  type 'a property_name = 'a t

  let name_as_value t = t |> name |> Symbol.to_value
  let sexp_of_t _ t = [%sexp (name t : Symbol.t)]
  let of_value_exn t = Value.Type.of_value_exn (type_ t)
  let to_value t = Value.Type.to_value (type_ t)
  let value_to_sexp t = Value.Type.to_sexp (type_ t)

  module Packed = struct
    type t = T : _ property_name -> t

    let sexp_of_t (T p) = [%sexp (p : _ t)]
    let name (T p) = name p
    let all_except_unknown = ref []

    let of_name_as_value_exn value =
      match Symbol.of_value_exn value with
      | exception _ ->
        raise_s
          [%message
            "[Text.Property.Packed.of_name_as_value_exn] got unexpected value"
              (value : Value.t)]
      | symbol ->
        (match
           List.find !all_except_unknown ~f:(fun t -> Symbol.equal symbol (name t))
         with
         | Some t -> t
         | None -> T { name = symbol; type_ = Value.Type.value })
    ;;
  end

  let create_and_register name type_ =
    let t = { name; type_ } in
    Packed.all_except_unknown := T t :: !Packed.all_except_unknown;
    t
  ;;

  module Create = struct
    let ( <: ) name type_ = create_and_register (Symbol.intern name) type_
  end

  let face : _ t = create_and_register Q.face Face_spec.type_
  let mouse_face : _ t = create_and_register Q.mouse_face Face_spec.type_
  let font_lock_face : _ t = create_and_register Q.font_lock_face Face_spec.type_
  let display : _ t = create_and_register Q.display Display_spec.type_
  let after_string : _ t = create_and_register Q.after_string text_type
  let before_string : _ t = create_and_register Q.before_string text_type
  let invisible : _ t = create_and_register Q.invisible Value.Type.value
  let help_echo : _ t = create_and_register Q.help_echo Value.Type.string
  let kbd_help : _ t = create_and_register Q.kbd_help Value.Type.string
end

module Property = struct
  type t = T : 'a Property_name.t * 'a -> t

  let sexp_of_t (T (property_name, property_value)) =
    [%message
      ""
        ~_:(Property_name.name property_name : Symbol.t)
        ~_:(Property_name.value_to_sexp property_name property_value : Sexp.t)]
  ;;

  let rec of_property_list_exn value =
    if Value.is_nil value
    then []
    else if not (Value.is_cons value)
    then
      raise_s
        [%message
          "[Text.Property.of_property_list_exn] got unexpected value" (value : Value.t)]
    else
      let module N = Property_name.Packed in
      let (N.T property_name) = Value.car_exn value |> N.of_name_as_value_exn in
      let property_value_and_rest = Value.cdr_exn value in
      T
        ( property_name
        , Value.car_exn property_value_and_rest
          |> Property_name.of_value_exn property_name )
      :: of_property_list_exn (Value.cdr_exn property_value_and_rest)
  ;;

  let to_property_list ts =
    List.fold (List.rev ts) ~init:[] ~f:(fun ac (T (name, value)) ->
      let type_ = Property_name.type_ name in
      (Property_name.name name |> Symbol.to_value)
      :: (value |> Value.Type.to_value type_)
      :: ac)
  ;;
end

let propertize t properties =
  Symbol.funcallN
    Q.propertize
    ((t |> to_value) :: (properties |> Property.to_property_list))
  |> of_value_exn
;;

let colorize t ~color =
  propertize
    t
    [ T (Property_name.face, [ Face_spec.One.Attributes [ T (Foreground, Color color) ] ])
    ]
;;

let get_text_property =
  Funcall.Wrap.("get-text-property" <: int @-> Symbol.t @-> t @-> return value)
;;

let property_value t ~at property_name =
  let value = get_text_property at (property_name |> Property_name.name) t in
  if Value.is_nil value
  then None
  else Some (value |> Property_name.of_value_exn property_name)
;;

let text_properties_at = Funcall.Wrap.("text-properties-at" <: int @-> t @-> return value)
let properties t ~at = text_properties_at at t |> Property.of_property_list_exn

let get_start start =
  match start with
  | Some i -> i
  | None -> 0
;;

let get_end t end_ =
  match end_ with
  | Some i -> i
  | None -> length t
;;

let put_text_property =
  Funcall.Wrap.(
    "put-text-property" <: int @-> int @-> Symbol.t @-> value @-> t @-> return nil)
;;

let set_property ?start ?end_ t property_name property_value =
  put_text_property
    (start |> get_start)
    (end_ |> get_end t)
    (property_name |> Property_name.name)
    (property_value |> Property_name.to_value property_name)
    t
;;

let add_text_properties =
  Funcall.Wrap.("add-text-properties" <: int @-> int @-> list value @-> t @-> return nil)
;;

let add_properties ?start ?end_ t properties =
  add_text_properties
    (start |> get_start)
    (end_ |> get_end t)
    (properties |> Property.to_property_list)
    t
;;

let set_text_properties =
  Funcall.Wrap.("set-text-properties" <: int @-> int @-> list value @-> t @-> return nil)
;;

let set_properties ?start ?end_ t properties =
  set_text_properties
    (start |> get_start)
    (end_ |> get_end t)
    (properties |> Property.to_property_list)
    t
;;

let remove_list_of_text_properties =
  Funcall.Wrap.(
    "remove-list-of-text-properties" <: int @-> int @-> list Symbol.t @-> t @-> return nil)
;;

let remove_properties ?start ?end_ t property_names =
  remove_list_of_text_properties
    (start |> get_start)
    (end_ |> get_end t)
    (property_names |> List.map ~f:Property_name.Packed.name)
    t
;;

let is_multibyte = Funcall.Wrap.("multibyte-string-p" <: t @-> return bool)
let num_bytes = Funcall.Wrap.("string-bytes" <: t @-> return int)
let to_multibyte = Funcall.Wrap.("string-to-multibyte" <: t @-> return t)
let to_unibyte_exn = Funcall.Wrap.("string-to-unibyte" <: t @-> return t)

let of_char_array chars =
  Symbol.funcallN_array Q.string (Array.map chars ~f:Char_code.to_value) |> of_value_exn
;;

external to_char_array : t -> Char_code.t array = "ecaml_text_to_char_array"
OCaml

Innovation. Community. Security.