forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Replace Compartment with StateField for message decorations
The Compartment+reconfigure approach caused "Position out of range for
changeset" RangeErrors because decorations weren't mapped through
document change transactions. A StateField maps decorations via
RangeSet.map(tr.changes) synchronously within each transaction,
keeping positions consistent with the document state.
- Add StateEffect and StateField OCaml bindings to jsoo-code-mirror
- Add Decoration.Range_set.empty and .map
- Convert editor.ml messages from Compartment to StateField+StateEffect
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+94
-21
+3
-1
jsoo-code-mirror/includes/includes.js
+3
-1
jsoo-code-mirror/includes/includes.js
···
1
1
import { EditorView, basicSetup } from "codemirror"
2
-
import { EditorState, Compartment, RangeSet } from "@codemirror/state"
2
+
import { EditorState, Compartment, RangeSet, StateField, StateEffect } from "@codemirror/state"
3
3
import { hoverTooltip, lineNumbers, Decoration, WidgetType } from "@codemirror/view"
4
4
import * as lint from "@codemirror/lint"
5
5
import * as autocomplete from "@codemirror/autocomplete"
···
16
16
joo_global_object.__CM__autocomplete = autocomplete;
17
17
joo_global_object.__CM__hoverTooltip = hoverTooltip;
18
18
joo_global_object.__CM__lineNumbers = lineNumbers;
19
+
joo_global_object.__CM__StateField = StateField;
20
+
joo_global_object.__CM__StateEffect = StateEffect;
19
21
joo_global_object.__CM__basic_setup = basicSetup
20
22
joo_global_object.__CM__stream_parser = language;
21
23
joo_global_object.__CM__mllike = oCaml;
+2
jsoo-code-mirror/src/code_mirror.ml
+2
jsoo-code-mirror/src/code_mirror.ml
+3
jsoo-code-mirror/src/decoration.ml
+3
jsoo-code-mirror/src/decoration.ml
+2
jsoo-code-mirror/src/decoration.mli
+2
jsoo-code-mirror/src/decoration.mli
+9
jsoo-code-mirror/src/state_effect.ml
+9
jsoo-code-mirror/src/state_effect.ml
···
1
+
type t = Jv.t
2
+
3
+
include (Jv.Id : Jv.CONV with type t := t)
4
+
5
+
let state_effect = Jv.get Jv.global "__CM__StateEffect"
6
+
let define () = Jv.call state_effect "define" [||]
7
+
let of_ t v = Jv.call t "of" [| v |]
8
+
let is instance t = Jv.to_bool (Jv.call instance "is" [| t |])
9
+
let value instance = Jv.get instance "value"
+17
jsoo-code-mirror/src/state_effect.mli
+17
jsoo-code-mirror/src/state_effect.mli
···
1
+
type t
2
+
(** An effect type definition, created with {!define}. *)
3
+
4
+
include Jv.CONV with type t := t
5
+
6
+
val define : unit -> t
7
+
(** [define ()] creates a new effect type. *)
8
+
9
+
val of_ : t -> Jv.t -> Jv.t
10
+
(** [of_ effect_type value] creates an effect instance carrying [value]. *)
11
+
12
+
val is : Jv.t -> t -> bool
13
+
(** [is instance effect_type] returns [true] if [instance] was created from
14
+
[effect_type]. *)
15
+
16
+
val value : Jv.t -> Jv.t
17
+
(** [value instance] returns the value carried by an effect instance. *)
+11
jsoo-code-mirror/src/state_field.ml
+11
jsoo-code-mirror/src/state_field.ml
···
1
+
let state_field = Jv.get Jv.global "__CM__StateField"
2
+
3
+
let define ~create ~update ~provide =
4
+
let spec = Jv.obj [||] in
5
+
Jv.set spec "create"
6
+
(Jv.callback ~arity:1 (fun _state -> create ()));
7
+
Jv.set spec "update"
8
+
(Jv.callback ~arity:2 (fun value tr -> update value tr));
9
+
Jv.set spec "provide"
10
+
(Jv.callback ~arity:1 (fun field -> Extension.to_jv (provide field)));
11
+
Jv.call state_field "define" [| spec |] |> Extension.of_jv
+11
jsoo-code-mirror/src/state_field.mli
+11
jsoo-code-mirror/src/state_field.mli
···
1
+
val define :
2
+
create:(unit -> Jv.t) ->
3
+
update:(Jv.t -> Jv.t -> Jv.t) ->
4
+
provide:(Jv.t -> Extension.t) ->
5
+
Extension.t
6
+
(** [define ~create ~update ~provide] creates a state field extension.
7
+
8
+
- [create ()] returns the initial field value.
9
+
- [update value transaction] computes the new value for each transaction.
10
+
- [provide field] returns an extension that derives a facet from the field
11
+
(e.g. [EditorView.decorations.from(field)]). *)
+36
-20
x-ocaml/src/editor.ml
+36
-20
x-ocaml/src/editor.ml
···
1
1
type t = {
2
2
view : Code_mirror.Editor.View.t;
3
-
messages_comp : Code_mirror.Compartment.t;
4
3
lines_comp : Code_mirror.Compartment.t;
5
4
merlin_comp : Code_mirror.Compartment.t;
6
5
mutable merlin_extension : unit -> Code_mirror.Extension.t list;
···
16
15
in
17
16
go at
18
17
19
-
let render_messages cm =
20
-
let open Code_mirror.Editor in
18
+
let set_messages_effect = Code_mirror.State_effect.define ()
19
+
20
+
let messages_field =
21
+
Code_mirror.State_field.define
22
+
~create:(fun () ->
23
+
Code_mirror.Decoration.Range_set.(to_jv empty))
24
+
~update:(fun decos tr ->
25
+
let open Code_mirror.Decoration in
26
+
let decos = Range_set.map (Range_set.of_jv decos) (Jv.get tr "changes") in
27
+
let effects = Jv.to_jv_array (Jv.get tr "effects") in
28
+
Range_set.to_jv
29
+
(Array.fold_left
30
+
(fun acc e ->
31
+
if Code_mirror.State_effect.is e set_messages_effect then
32
+
Range_set.of_jv (Code_mirror.State_effect.value e)
33
+
else acc)
34
+
decos effects))
35
+
~provide:(fun field ->
36
+
let deco_facet =
37
+
Jv.get (Jv.get Jv.global "__CM__view") "decorations"
38
+
in
39
+
Jv.call deco_facet "from" [| field |] |> Code_mirror.Extension.of_jv)
40
+
41
+
let build_range_set cm =
21
42
let open Code_mirror.Decoration in
22
-
let (State.Facet ((module F), it)) = View.decorations () in
23
43
let doc = cm.current_doc in
24
44
let ranges =
25
45
Array.of_list
···
31
51
@@ List.map (fun (at, msg) ->
32
52
let at = min at (String.length doc) in
33
53
let at = find_line_ends at doc in
34
-
(* Clamp to last character — decorations at doc.length can cause
35
-
RangeError when CodeMirror maps them through changesets *)
36
54
let at = min at (max 0 (String.length doc - 1)) in
37
55
(at, msg))
38
56
@@ List.concat
39
57
@@ List.map (fun (loc, lst) -> List.map (fun m -> (loc, m)) lst)
40
58
@@ List.sort (fun (a, _) (b, _) -> Int.compare a b) cm.messages
41
59
in
42
-
try F.of_ it (Range_set.of' ranges)
43
-
with _ -> F.of_ it (Range_set.of' [||])
60
+
try Range_set.of' ranges with _ -> Range_set.of' [||]
44
61
45
62
let refresh_messages ed =
46
-
try
47
-
Code_mirror.Editor.View.dispatch ed.view
48
-
(Code_mirror.Compartment.reconfigure ed.messages_comp
49
-
[ render_messages ed ])
50
-
with _ -> ()
51
-
(* RangeError can occur when CodeMirror maps decoration positions
52
-
through changesets if the cached doc length differs from the
53
-
actual CodeMirror document length. Swallow to prevent cascade
54
-
failures in the cell execution chain. *)
63
+
let range_set = build_range_set ed in
64
+
let effect =
65
+
Code_mirror.State_effect.of_ set_messages_effect
66
+
(Code_mirror.Decoration.Range_set.to_jv range_set)
67
+
in
68
+
let txn =
69
+
Jv.obj [| ("effects", effect) |]
70
+
|> Code_mirror.Editor.View.Transaction.of_jv
71
+
in
72
+
try Code_mirror.Editor.View.dispatch ed.view txn with _ -> ()
55
73
56
74
let custom_ln editor =
57
75
Code_mirror.Editor.View.line_numbers (fun x ->
···
100
118
let make ?(read_only = false) parent =
101
119
let open Code_mirror.Editor in
102
120
let changes = Code_mirror.Compartment.make () in
103
-
let messages = Code_mirror.Compartment.make () in
104
121
let lines = Code_mirror.Compartment.make () in
105
122
let merlin = Code_mirror.Compartment.make () in
106
123
let extensions =
···
109
126
basic_setup;
110
127
Code_mirror.Editor.View.line_wrapping ();
111
128
Code_mirror.Compartment.of' lines [];
112
-
Code_mirror.Compartment.of' messages [];
129
+
messages_field;
113
130
Code_mirror.Compartment.of' changes [];
114
131
Code_mirror.Compartment.of' merlin [];
115
132
|]
···
124
141
current_doc = "";
125
142
messages = [];
126
143
view;
127
-
messages_comp = messages;
128
144
lines_comp = lines;
129
145
merlin_comp = merlin;
130
146
merlin_extension = (fun () -> []);