path: root/editor/prosemirror/prosemirror.ml

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 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