forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Revert "Replace Compartment with StateField for message decorations"
This reverts commit 051c718e8b619909d2f4199f6b5fbcd0642c5364.
+21
-94
+1
-3
jsoo-code-mirror/includes/includes.js
+1
-3
jsoo-code-mirror/includes/includes.js
···
1
1
import { EditorView, basicSetup } from "codemirror"
2
-
import { EditorState, Compartment, RangeSet, StateField, StateEffect } from "@codemirror/state"
2
+
import { EditorState, Compartment, RangeSet } 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;
21
19
joo_global_object.__CM__basic_setup = basicSetup
22
20
joo_global_object.__CM__stream_parser = language;
23
21
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)]). *)
+20
-36
x-ocaml/src/editor.ml
+20
-36
x-ocaml/src/editor.ml
···
1
1
type t = {
2
2
view : Code_mirror.Editor.View.t;
3
+
messages_comp : Code_mirror.Compartment.t;
3
4
lines_comp : Code_mirror.Compartment.t;
4
5
merlin_comp : Code_mirror.Compartment.t;
5
6
mutable merlin_extension : unit -> Code_mirror.Extension.t list;
···
15
16
in
16
17
go at
17
18
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 =
19
+
let render_messages cm =
20
+
let open Code_mirror.Editor in
42
21
let open Code_mirror.Decoration in
22
+
let (State.Facet ((module F), it)) = View.decorations () in
43
23
let doc = cm.current_doc in
44
24
let ranges =
45
25
Array.of_list
···
51
31
@@ List.map (fun (at, msg) ->
52
32
let at = min at (String.length doc) in
53
33
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 *)
54
36
let at = min at (max 0 (String.length doc - 1)) in
55
37
(at, msg))
56
38
@@ List.concat
57
39
@@ List.map (fun (loc, lst) -> List.map (fun m -> (loc, m)) lst)
58
40
@@ List.sort (fun (a, _) (b, _) -> Int.compare a b) cm.messages
59
41
in
60
-
try Range_set.of' ranges with _ -> Range_set.of' [||]
42
+
try F.of_ it (Range_set.of' ranges)
43
+
with _ -> F.of_ it (Range_set.of' [||])
61
44
62
45
let refresh_messages ed =
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 _ -> ()
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. *)
73
55
74
56
let custom_ln editor =
75
57
Code_mirror.Editor.View.line_numbers (fun x ->
···
118
100
let make ?(read_only = false) parent =
119
101
let open Code_mirror.Editor in
120
102
let changes = Code_mirror.Compartment.make () in
103
+
let messages = Code_mirror.Compartment.make () in
121
104
let lines = Code_mirror.Compartment.make () in
122
105
let merlin = Code_mirror.Compartment.make () in
123
106
let extensions =
···
126
109
basic_setup;
127
110
Code_mirror.Editor.View.line_wrapping ();
128
111
Code_mirror.Compartment.of' lines [];
129
-
messages_field;
112
+
Code_mirror.Compartment.of' messages [];
130
113
Code_mirror.Compartment.of' changes [];
131
114
Code_mirror.Compartment.of' merlin [];
132
115
|]
···
141
124
current_doc = "";
142
125
messages = [];
143
126
view;
127
+
messages_comp = messages;
144
128
lines_comp = lines;
145
129
merlin_comp = merlin;
146
130
merlin_extension = (fun () -> []);