summaryrefslogtreecommitdiff
path: root/editor/prosemirror/prosemirror.ml
blob: 2a9b92c315094557fcd108946f45ccf7c8e87d14 (plain)
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
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
open Js_of_ocaml
open Brr

type t = Jv.t

type t' = t

let v
  : unit -> t
  = fun () ->
    Jv.get Jv.global "PM"

module O = Bindings.TypedObject

module Model = struct

  include Bindings.Model

  module Mark = struct

    let _set_from
      : t -> 'a Js.t -> mark Js.t
      = fun t element ->
        let model = Jv.get t "model" in
        let class_ = Jv.get model "Mark" in
        Jv.call (Jv.Id.to_jv class_ ) "setFrom" [|Jv.Id.to_jv element |]
        |> Jv.Id.of_jv


    let set_from_mark
      : t -> mark Js.t -> mark Js.t
      = _set_from


  end

  module DOMParser = struct


    type parser = Jv.t

    let from_schema
      : t -> schema Js.t -> parser
      = fun t schema ->
        let model = Jv.get t "model" in
        let parser = Jv.get model "DOMParser" in
        Jv.call (Jv.Id.to_jv parser) "fromSchema" [|Jv.Id.to_jv schema|]

    let parse
      : parser -> El.t -> node Js.t
      = fun dom_parser el ->
        Jv.call dom_parser "parse" [|Jv.Id.to_jv el|]
        |> Jv.Id.of_jv

  end

  let schema_spec:
    node_spec Bindings.ordered_map Js.t
    -> mark_spec Bindings.ordered_map Js.t option
    -> string option
    -> schema_spec Js.t
    = fun nodes marks_opt topNode_opt ->
      let marks = Jv.of_option ~none:Jv.null Jv.Id.to_jv marks_opt
      and topNode = Jv.of_option ~none:Jv.null Jv.of_string topNode_opt in
      Jv.obj
        [| "nodes", (Jv.Id.to_jv nodes)
         ; "marks", marks
         ; "topNode", topNode
        |]
      |> Jv.Id.of_jv


  let schema
    : t -> schema_spec Js.t -> schema Js.t
    = fun t spec ->
      let model = Jv.get t "model" in
      Jv.new' (Jv.get model "Schema") [| Jv.Id.to_jv spec |]
      |> Jv.Id.of_jv


  let empty_fragment
    : t -> fragment Js.t
    = fun t ->
      let model = Jv.get t "model" in
      let fragment = Jv.get model "Fragment" in
      Jv.get fragment "empty"
      |> Jv.Id.of_jv

  module Dom_output_spec = struct

    let v
      : ?attrs:< .. > -> string -> domOutputSpec Js.t list -> domOutputSpec Js.t
      = fun ?attrs name elems ->

        let elems = match attrs with
          | None -> elems
          | Some v -> Jv.Id.(of_jv @@ to_jv @@ v)::elems in

        let elems = (Jv.Id.of_jv @@ Jv.of_string name)::elems in
        (Jv.of_list Jv.Id.to_jv elems)
        |> Jv.Id.to_jv
        |> Jv.Id.of_jv

    let hole
      : domOutputSpec Js.t
      = 0
        |> Jv.Id.to_jv
        |> Jv.Id.of_jv

    let of_
      : 'a -> domOutputSpec Js.t
      = fun elem ->
        elem
        |> Jv.Id.to_jv
        |> Jv.Id.of_jv

    let of_el
      : Brr.El.t -> domOutputSpec Js.t
      = of_

    let of_jstr
      : Jstr.t -> domOutputSpec Js.t
      = of_

    let of_obj
      : < dom: node Js.t Js.readonly_prop ; contentDOM : node Js.t Js.opt Js.readonly_prop > Js.t -> domOutputSpec Js.t
      = of_
  end

  module ParseRule = struct

    let tag
      : Jstr.t -> parse_rule Js.t
      = fun name ->
        Jv.obj [| "tag", Jv.of_jstr name |]
        |> Jv.Id.of_jv

  end
end

module State = struct

  include Bindings.State

  let configuration_prop
    : unit -> configuration_prop Js.t
    = fun () -> Js.Unsafe.obj [||]

  let creation_prop
    : unit -> creation_prop Js.t
    = fun () -> Js.Unsafe.obj [||]

  let create
    : t -> creation_prop Js.t -> editor_state Js.t
    = fun t props ->
      let state = Jv.get t "state" in
      let editor_state = Jv.get state "EditorState" in
      Jv.call editor_state "create" [|Jv.Id.to_jv props|]
      |> Jv.Id.of_jv

  let fromJSON
    : t -> configuration_prop Js.t -> Brr.Json.t -> editor_state Js.t
    = fun t config json ->
      let state = Jv.get t "state" in
      let editor_state = Jv.get state "EditorState" in
      Jv.call editor_state "fromJSON" [|Jv.Id.to_jv config ; json |]
      |> Jv.Id.of_jv

  let selection_from
    : selection Js.t -> Model.resolved_pos Js.t
    = fun selection ->
      Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$from")

  let selection_to
    : selection Js.t -> Model.resolved_pos Js.t
    = fun selection ->
      Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$to")

  let node_selection
    : t -> Model.resolved_pos Js.t -> node_selection Js.t
    = fun t pos ->
      let state = Jv.get t "state" in
      Jv.new' (Jv.get state "NodeSelection") [| Jv.Id.to_jv pos |]
      |> Jv.Id.of_jv

  let is_selectable
    : t -> Model.node Js.t -> bool Js.t
    = fun t node ->
      let selection = Jv.get (Jv.get t "state") "NodeSelection" in
      Jv.call selection "isSelectable" [|Jv.Id.to_jv node|]
      |> Jv.Id.of_jv

  let selection_at_start
    : t-> Model.node Js.t -> selection Js.t
    = fun t node ->
      let selection = Jv.get (Jv.get t "state") "NodeSelection" in
      Jv.call selection "atStart" [|Jv.Id.to_jv node|]
      |> Jv.Id.of_jv


  let create_node_selection
    : t -> Model.node Js.t -> int -> node_selection Js.t
    = fun t doc number ->
      let state = Jv.get t "state" in
      Jv.call (Jv.get state "NodeSelection") "create" Jv.Id.[|to_jv doc; Jv.of_int number|]
      |> Jv.Id.of_jv

  let create_text_selection
    : t -> Model.node Js.t -> int -> node_selection Js.t
    = fun t doc number ->
      let state = Jv.get t "state" in
      Jv.call (Jv.get state "TextSelection") "create" Jv.Id.[|to_jv doc; Jv.of_int number|]
      |> Jv.Id.of_jv

  let cursor
    : selection Js.t -> Model.resolved_pos Js.t Js.opt
    = fun selection ->
      Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$cursor")

  let create_str_meta_data
    : Jstr.t -> 'a meta_data Js.t
    = Obj.magic
end

(* Editor view *)

module View = struct

  module EditorProps = struct
    type t = Jv.t
  end

  include Bindings.View
  let direct_editor_props
    : unit -> direct_editor_props Js.t
    = fun () -> Js.Unsafe.obj [||]

  let editor_view
    : t -> El.t -> direct_editor_props Js.t -> editor_view Js.t
    = fun t node props ->
      Jv.new' (Jv.get (Jv.get t "view") "EditorView") [|Jv.Id.to_jv node ; Jv.Id.to_jv props|]
      |> Jv.Id.of_jv

end

module Transform = struct

  include Bindings.Transform

  let offset
    : t -> int -> step_map Js.t
    = fun t n ->
      let stepmap = Jv.get (Jv.get t "transform") "StepMap" in
      Jv.call stepmap "offset" [|Jv.Id.to_jv n|]
      |> Jv.Id.of_jv

  let insertPoint
    : t -> Model.node Js.t -> pos:int -> Model.node_type Js.t -> int Js.opt
    = fun t node ~pos node_t ->
      let transform = Jv.get t "transform" in
      Jv.call transform "insertPoint" Jv.Id.[|to_jv node ; to_jv pos; to_jv node_t|]
      |> Jv.Id.of_jv

end

module Commands = struct

  type t = State.editor_state Js.t -> State.dispatch Js.opt -> bool Js.t

  let baseKeymap
    : t' -> (string * t) array
    = fun t ->
      Jv.get (Jv.get t "commands") "baseKeymap"
      |> Jv.Id.of_jv

  let set_block_type
    : t' -> Model.node_type Js.t -> < .. > Js.t Js.opt -> t
    = fun t node props ->
      Jv.call (Jv.get t "commands") "setBlockType" Jv.Id.[| to_jv node ; to_jv props |]
      |> Jv.Id.of_jv

  let toggle_mark
    : t' -> Model.mark_type Js.t -> < .. > Js.t Js.opt -> t
    = fun t mark props ->
      Jv.call (Jv.get t "commands") "toggleMark" Jv.Id.[| to_jv mark ; to_jv props |]
      |> Jv.Id.of_jv


end


module History = struct

  include Bindings.History

  let history_prop
    : unit -> history_prop Js.t
    = fun () -> Js.Unsafe.obj [||]

  let history
    : t -> history_prop Js.t -> State.plugin Js.t
    = fun t props ->
      Jv.call (Jv.get t "history") "history" [|Jv.Id.to_jv props|]
      |> Jv.Id.of_jv

  let undo
    : t -> Commands.t
    = fun t state fn ->
      Jv.call (Jv.get t "history") "undo" [|Jv.Id.to_jv state; Jv.repr fn|]
      |> Jv.Id.of_jv

  let redo
    : t -> Commands.t
    = fun t state fn ->
      Jv.call (Jv.get t "history") "redo" [|Jv.Id.to_jv state; Jv.repr fn|]
      |> Jv.Id.of_jv
end

module Keymap = struct

  let keymap
    : t -> (string * Commands.t) array -> State.plugin Js.t
    = fun t props ->
      let props = Jv.obj @@ Array.map (fun (id, f) -> (id, Jv.repr f)) props in
      Jv.call (Jv.get t "keymap") "keymap" [|props|]
      |> Jv.Id.of_jv

end

module InputRule = struct

  type input_rule

  let create
    : t -> Js.regExp Js.t -> fn:(State.editor_state Js.t -> Jstr.t Js.js_array Js.t -> from:int -> to_:int -> State.transaction Js.t Js.opt) Js.callback -> input_rule Js.t
    = fun t match' ~fn ->
      Jv.new' (Jv.get (Jv.get t "inputrules") "InputRule") [|Jv.Id.to_jv match' ; Jv.Id.to_jv fn|]
      |> Jv.Id.of_jv

  let to_plugin
    : t -> input_rule Js.t Js.js_array Js.t -> State.plugin Js.t
    = fun t rules ->
      let obj = Jv.obj [|("rules", Jv.Id.to_jv rules)|] in
      Jv.call (Jv.get t "inputrules") "inputRules" [| obj |]
      |> Jv.Id.of_jv

end

module SchemaBasic = struct

  include Bindings.SchemaBasic

  let schema
    : t -> Model.schema Js.t
    = fun t ->
      Jv.get (Jv.get t "schema_basic") "schema"
      |> Jv.Id.of_jv

  let nodes
    : t -> nodes Js.t
    = fun t ->
      Jv.get (Jv.get t "schema_basic") "nodes"
      |> Jv.Id.of_jv

end

module SchemaList = struct

  let add_list_nodes
    : t -> Model.node_spec Bindings.ordered_map Js.t -> Jstr.t -> Jstr.t option -> Model.node_spec Bindings.ordered_map Js.t
    = fun t nodes item_content list_group_opt ->
      let schema_list = Jv.get t "schema_list" in

      let list_group = Jv.of_option ~none:Jv.null Jv.of_jstr list_group_opt in

      Jv.call schema_list "addListNodes"
        [|Jv.Id.to_jv nodes
         ; Jv.of_jstr item_content
         ; list_group |]
      |> Jv.Id.of_jv

end

module Menu = struct

  include Bindings.Menu

  let menuItemSpec
    : unit -> menuItemSpec Js.t
    = fun () -> Js.Unsafe.obj [||]

  let menu_item
    : t -> menuItemSpec Js.t -> menuItem Js.t
    = fun t spec ->
      let menu = Jv.get t "menu" in
      Jv.new' (Jv.get menu "MenuItem") [| Jv.Id.to_jv spec |]
      |> Jv.Id.of_jv

end

(* Example Setup *)

module Example = struct

  include Bindings.Example

  let options
    : Model.schema Js.t -> options Js.t
    = fun schema ->
      Jv.obj [|("schema", Jv.Id.to_jv schema)|]
      |> Jv.Id.of_jv

  let example_setup
    : t -> options Js.t -> State.plugin Js.t Js.js_array Js.t
    = fun t options ->
      let setup = Jv.get t "example_setup" in
      Jv.call setup "exampleSetup" [|Jv.Id.to_jv options|]
      |> Jv.Id.of_jv

  let buildMenuItems
    : t -> Model.schema Js.t -> menuItems Js.t
    = fun t schema ->
      let setup = Jv.get t "example_setup" in
      Jv.call setup "buildMenuItems" [|Jv.Id.to_jv schema|]
      |> Jv.Id.of_jv
end