path: root/editor/prosemirror/prosemirror.ml

open Brr
module Js = Js_of_ocaml.Js

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 Fragment = struct
    (** https://prosemirror.net/docs/ref/#model.Fragment^fromArray *)
    let from_array : t -> node Js.t Js.js_array Js.t -> fragment Js.t =
     fun t elements ->
      let model = Jv.get t "model" in
      let class_ = Jv.get model "Fragment" in
      Jv.call (Jv.Id.to_jv class_) "fromArray" [| Jv.Id.to_jv elements |]
      |> Jv.Id.of_jv
  end

  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

  (** Create a new inputRule. 

  The callback is called with the following elements :
      - the editor state
      - the elements matched by the regex
      - starting position 
      - ending position

  and shall return a transaction if any modifications are applied. *)
  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