summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2021-02-24 20:51:43 +0100
committerSébastien Dailly <sebastien@dailly.me>2022-02-07 16:43:33 +0100
commit3f5e3dd53755dd67c24721afc62e32d2187e3583 (patch)
tree16d4e694a1adeb83abcaea12da8fb0a16a11ed00
parent274789e733c46e7e20fc1dc918a7251b0206b3d2 (diff)
Update editor code
-rw-r--r--editor/editor.css52
-rwxr-xr-xeditor/editor.ml164
-rwxr-xr-xeditor/index.html130
-rwxr-xr-xeditor/plugins.ml134
-rwxr-xr-xeditor/prosemirror/bindings.ml194
-rwxr-xr-xeditor/prosemirror/prosemirror.ml117
-rwxr-xr-xeditor/prosemirror/prosemirror.mli65
-rwxr-xr-xeditor/tooltip.ml149
8 files changed, 666 insertions, 339 deletions
diff --git a/editor/editor.css b/editor/editor.css
index fb58773..c8c2aeb 100644
--- a/editor/editor.css
+++ b/editor/editor.css
@@ -325,38 +325,70 @@ li.ProseMirror-selectednode:after {
.ProseMirror p { margin-bottom: 1em }
-.editor em::before, .editor em::after {
+.editor [contenteditable="true"] em::before, .editor [contenteditable="true"] em::after {
content: "//"
}
-.editor blockquote p::before {
+.editor [contenteditable="true"] blockquote p::before {
content: "> "
}
-.editor strong::before, .editor strong::after {
- content: "**"
+.editor [contenteditable="true"] strong::before, .editor [contenteditable="true"] strong::after {
+ content: "**";
+ display: inline-block;
+ pointer-events: none;
}
-.editor h1::before {
+.editor [contenteditable="true"] h1::before {
content: "# "
}
-.editor h2::before {
+.editor [contenteditable="true"] h2::before {
content: "## "
}
-.editor h3::before {
+.editor [contenteditable="true"] h3::before {
content: "### "
}
-.editor h4::before {
+.editor [contenteditable="true"] h4::before {
content: "#### "
}
-.editor h5::before {
+.editor [contenteditable="true"] h5::before {
content: "##### "
}
-.editor h6::before {
+.editor [contenteditable="true"] h6::before {
content: "###### "
}
+
+#title {
+ font-size:2.4em;
+ font-weight:300;
+ line-height:1.1;
+ font-family:Source Sans Pro,Roboto,Open Sans,Liberation Sans,DejaVu Sans,Verdana,Helvetica,Arial,sans-serif;
+ width:100%;
+
+}
+
+.editor a[href] {
+ position: relative;
+}
+.tooltip, .editor a[href]:hover::after {
+ position: absolute;
+ border: 1px #3b4252 solid;
+ border-radius: 10px;
+ background-color: #2e3440;
+ padding: 12px;
+ color: #eceff4;
+ font-size: 14px;
+ z-index: 99;
+ pointer-events: none;
+}
+
+.editor a[href]:hover::after {
+ content: attr(href);
+ left: 0;
+ top: 24px;
+}
diff --git a/editor/editor.ml b/editor/editor.ml
index d32288c..5aecef0 100755
--- a/editor/editor.ml
+++ b/editor/editor.ml
@@ -2,72 +2,6 @@ open Js_of_ocaml
open Brr
module PM = Prosemirror
-let change_level
- : PM.t -> PM.Model.resolved_pos Js.t -> int -> (int -> bool) -> PM.State.command
- = fun pm res incr pred state dispatch ->
- let parent = res##.parent in
- let attributes = parent##.attrs in
-
- let current_level = if Jv.is_none attributes##.level then
- 0
- else
- attributes##.level in
- let t, props = match pred current_level with
- | false ->
- (PM.O.get state##.schema##.nodes "heading"
- , (object%js
- val level = current_level + incr
- end :> < > Js.t ))
- | true ->
- ( PM.O.get state##.schema##.nodes "paragraph"
- , object%js end) in
- match t with
- | None -> Js._false
- | Some t ->
- PM.Commands.set_block_type pm t props state dispatch
-
-(** Increase the title level by one when pressing # at the begining of a line *)
-let handle_sharp pm state dispatch =
-
- let res = PM.State.selection_to (state##.selection) in
- match Js.Opt.to_option res##.nodeBefore with
- | Some _ -> Js._false
- | None -> (* Line start *)
- begin match Jstr.to_string res##.parent##._type##.name with
- | "heading" -> change_level pm res 1 (fun x -> x > 5) state dispatch
- | "paragraph" -> change_level pm res 1 (fun _ -> false) state dispatch
- | _ -> Js._false
- end
-
-let handle_backspace pm state dispatch =
-
- let res = PM.State.selection_to (state##.selection) in
- match Js.Opt.to_option res##.nodeBefore with
- | Some _ -> Js._false
- | None -> (* Line start *)
- begin match Jstr.to_string res##.parent##._type##.name with
- | "heading" -> change_level pm res (-1) (fun x -> x <= 1) state dispatch
- | _ -> Js._false
- end
-
-let default_plugins pm schema =
-
- let props = PM.Example.options schema in
- props##.menuBar := Js.some Js._true;
- props##.floatingMenu := Js.some Js._true;
- let setup = PM.Example.example_setup pm props in
-
- let keymaps =
- PM.Keymap.keymap pm
- [| "Backspace", (handle_backspace pm)
- ; "#", (handle_sharp pm)
- |] in
-
- (* Add the custom keymaps in the list *)
- let _ = setup##unshift keymaps in
-
- Js.some setup
-
let create_new_state pm mySchema content =
let module PM = Prosemirror in
@@ -78,13 +12,45 @@ let create_new_state pm mySchema content =
let props = PM.State.creation_prop () in
props##.doc := Js.some doc;
- props##.plugins := default_plugins pm mySchema;
+ props##.plugins := Plugins.default pm mySchema;
PM.State.create
pm
props
let storage_key = (Jstr.v "editor")
+
+let storage = Brr_io.Storage.local G.window
+
+(** Read the state from the local storage, or load the content from the given
+ element *)
+let load_storage
+ : PM.t -> PM.Model.schema Js.t -> Jv.t -> PM.State.editor_state Js.t
+ = fun pm schema content ->
+ let opt_data = Brr_io.Storage.get_item storage storage_key in
+ match opt_data with
+ | None -> create_new_state pm schema content
+ | Some contents ->
+ (* Try to load from the storage *)
+ match Json.decode contents with
+ | Error _ -> create_new_state pm schema content
+ | Ok json ->
+ let obj = PM.State.configuration_prop () in
+ obj##.plugins := Plugins.default pm schema;
+ obj##.schema := Js.some schema;
+ PM.State.fromJSON pm obj json
+
+let save_storage
+ : PM.View.editor_view Js.t -> unit
+ = fun view ->
+ let contents = view##.state##toJSON () in
+ let storage = Brr_io.Storage.local G.window in
+ Brr_io.Storage.set_item
+ storage
+ storage_key
+ (Json.encode @@ contents)
+ |> Console.log_if_error ~use:()
+
let prosemirror id content =
begin match (Jv.is_none id), (Jv.is_none content) with
| false, false ->
@@ -100,61 +66,57 @@ let prosemirror id content =
(Some (Jstr.v "block")))
(Some (PM.SchemaBasic.schema pm)##.spec##.marks)
None in
-
let mySchema = PM.Model.schema pm specs in
-
(* Create the initial state *)
- let storage = Brr_io.Storage.local G.window in
- let opt_data = Brr_io.Storage.get_item storage storage_key in
- let state = match opt_data with
- | None -> create_new_state pm mySchema content
- | Some contents ->
- (* Try to load from the storage *)
- begin match Json.decode contents with
- | Error _ -> create_new_state pm mySchema content
- | Ok json ->
- Console.(log [Jstr.v "Loading json"]);
-
- let history = PM.History.(history pm (history_prop ()) ) in
- let _ = history in
-
- let obj = PM.State.configuration_prop () in
- obj##.plugins := default_plugins pm mySchema;
- obj##.schema := Js.some mySchema;
- PM.State.fromJSON pm obj json
- end
- in
+ let state = load_storage pm mySchema content in
let props = PM.View.direct_editor_props () in
props##.state := state;
+ (* Each time the state is update, handle the copy *)
+ props##.dispatchTransaction := Js.wrap_meth_callback @@ (fun view tr ->
+ let state = view##.state##apply tr in
+ view##updateState state
+ );
let view = PM.View.editor_view
pm
(Jv.Id.of_jv id)
props in
-
-
view##setProps props;
-
(* Attach an event on focus out *)
- let _out_event = Brr_note.Evr.on_el
+ let _ = Brr_note.Evr.on_el
(Ev.focusout)
(fun _ ->
- let contents = view##.state##toJSON () in
-
- let storage = Brr_io.Storage.local G.window in
- Brr_io.Storage.set_item
- storage
- storage_key
- (Json.encode @@ contents)
- |> Console.log_if_error ~use:()
+(*
+ let props = view##.props in
+ props##.editable := Js.wrap_callback (fun _ -> Js._false);
+ view##update props;
+*)
+ save_storage view
+ )
+ (Jv.Id.of_jv id) in
+(*
+ let default_editable = view##.props##.editable in
+ let _ = Brr_note.Evr.on_el
+ (Ev.dblclick)
+ (fun e ->
+ let target = Ev.target e in
+ let (el:El.t) = Jv.Id.(of_jv @@ to_jv target) in
+ if (view##.editable == Js._false && (El.tag_name el <> Jstr.v "a")) then (
+ let props = view##.props in
+ props##.editable := default_editable;
+ view##update props;
+ Console.(log [el]);
+ El.set_has_focus true (Jv.Id.of_jv id);
+ )
)
(Jv.Id.of_jv id) in
+*)
()
| _, _-> Console.(error [str "No element with id '%s' '%s' found"; id ; content])
diff --git a/editor/index.html b/editor/index.html
index 9f7189b..ed1f9fe 100755
--- a/editor/index.html
+++ b/editor/index.html
@@ -1,18 +1,11 @@
-
<!DOCTYPE html>
<html lang="fr_fr">
<head>
<meta charset="utf-8" />
<meta http-equiv="X-UA-Compatible" content="IE=edge" />
- <meta name="HandheldFriendly" content="True" />
- <meta name="viewport" content="width=device-width, initial-scale=1.0" />
- <meta name="robots" content="noindex, nofollow" />
-
<link href="https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,300;0,400;0,700;1,400&display=swap" rel="stylesheet">
<link rel="stylesheet" type="text/css" href="/theme/stylesheet/style.min.css">
-
-
<link id="pygments-light-theme" rel="stylesheet" type="text/css"
href="//localhost:8000/theme/pygments/monokai.min.css">
@@ -21,26 +14,7 @@
<link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/brands.css">
<link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/solid.css">
<link rel="stylesheet" type="text/css" href="./editor.css">
-
- <link href="//localhost:8000/custom.css" rel="stylesheet">
-
- <link href="//localhost:8000/feeds/all.atom.xml" type="application/atom+xml" rel="alternate" title="Chimrod Atom">
-
-
-
-
-
- <meta name="author" content="Chimrod" />
- <meta name="description" content="" />
-<meta property="og:site_name" content="Chimrod"/>
-<meta property="og:type" content="blog"/>
-<meta property="og:title" content="Chimrod"/>
-<meta property="og:description" content=""/>
-<meta property="og:locale" content="en_US"/>
-<meta property="og:url" content="//localhost:8000"/>
-<meta property="og:image" content="/images/profile.png">
-
-
+ <link href="//localhost:8000/custom.css" rel="stylesheet">
<title>Chimrod &ndash; Editor</title>
@@ -55,24 +29,18 @@
<body class="light-theme">
<aside>
<div>
- <a href="//localhost:8000">
+ <a href="/">
<img src="/profile.png" alt="Chimrod" title="Chimrod">
</a>
<h1>
<a href="//localhost:8000">Chimrod</a>
</h1>
-
-
-
<nav>
<ul class="list">
-
-
-
- <li>
- <a target="_self" href="http://git.chimrod.com" >git</a>
- </li>
+ <li>
+ <a target="_self" href="http://git.chimrod.com" >git</a>
+ </li>
</ul>
</nav>
@@ -82,73 +50,39 @@
</aside>
<main>
-
- <nav>
- <a href="//localhost:8000">Accueil</a>
-
-
- <a href="//localhost:8000/feeds/all.atom.xml">Atom</a>
-
- </nav>
-
-<article class="single">
- <header>
+ <article class="single">
+ <header>
+ <input type="text" id="title" value="Titre" />
+ </header>
+ <div>
+ <div id="text_editor" class="editor" style="margin-bottom: 23px; height: 350px;"></div>
- <h1 id="title">Editor</h1>
- </header>
- <div>
-<div id="text_editor" class="editor" style="margin-bottom: 23px; height: 350px;"></div>
-<div style="display: none" id="content">
- <textarea>
- <h3>Hello ProseMirror</h3>
- <p>This is editable text. You can focus it and start typing.</p>
- <p>To apply styling, you can select a piece of text and manipulate
- its styling from the menu. The basic schema</p>
- </textarea>
-</div>
-
-
-
-
-<script src="/resources/prosemirror.js"></script>
-
- <noscript>Sorry, you need to enable JavaScript to see this page.</noscript>
- <script id="script" type="text/javascript" defer="defer" src="editor.js"></script>
- <script>
- var script = document.getElementById('script');
- script.addEventListener('load', function() {
- var prose = document.getElementById('text_editor');
- var content = document.getElementById('content');
- editor.attach_prosemirror(prose, content);
- });
- </script>
-
-
-
- <footer class="info"> </footer>
- </div>
-</article>
+ <div style="display: none" id="content">
+ <h3>Hello ProseMirror</h3>
+ <p>This is editable text. You can focus it and start typing.</p>
+ <p>To apply styling, you can select a piece of text and manipulate
+ its styling from the menu. The basic schema</p>
+ </div>
+
+ <script src="/resources/prosemirror.js"></script>
+ <noscript>Sorry, you need to enable JavaScript to see this page.</noscript>
+ <script id="script" type="text/javascript" defer="defer" src="editor.js"></script>
+ <script>
+ var script = document.getElementById('script');
+ script.addEventListener('load', function() {
+ var prose = document.getElementById('text_editor');
+ var content = document.getElementById('content');
+ editor.attach_prosemirror(prose, content);
+ });
+ </script>
+ <footer class="info"> </footer>
+ </div>
+ </article>
<footer>
<p>&copy; </p>
<p>
</p> </footer>
</main>
-
-
-
-
-<script type="application/ld+json">
-{
- "@context" : "http://schema.org",
- "@type" : "Blog",
- "name": " Chimrod ",
- "url" : "//localhost:8000",
- "image": "./profile.png",
- "description": ""
-}
-</script>
-
-
</body>
</html>
diff --git a/editor/plugins.ml b/editor/plugins.ml
new file mode 100755
index 0000000..6173c4f
--- /dev/null
+++ b/editor/plugins.ml
@@ -0,0 +1,134 @@
+open Js_of_ocaml
+module PM = Prosemirror
+
+(** Commands *)
+
+let change_level
+ : PM.t -> PM.Model.resolved_pos Js.t -> int -> (int -> bool) -> PM.Commands.t
+ = fun pm res incr pred state dispatch ->
+ let parent = res##.parent in
+ let attributes = parent##.attrs in
+
+ let current_level = if Jv.is_none attributes##.level then
+ 0
+ else
+ attributes##.level in
+ let t, props = match pred current_level with
+ | false ->
+ ( PM.O.get state##.schema##.nodes "heading"
+ , Js.some (object%js
+ val level = current_level + incr
+ end))
+ | true ->
+ ( PM.O.get state##.schema##.nodes "paragraph"
+ , Js.null) in
+ match t with
+ | None -> Js._false
+ | Some t ->
+ PM.Commands.set_block_type pm t props state dispatch
+
+(** Increase the title level by one when pressing # at the begining of a line *)
+let handle_sharp pm state dispatch =
+
+ let res = PM.State.selection_to (state##.selection) in
+ match Js.Opt.to_option res##.nodeBefore with
+ | Some _ -> Js._false
+ | None -> (* Line start *)
+ begin match Jstr.to_string res##.parent##._type##.name with
+ | "heading" ->
+ change_level pm res 1 (fun x -> x > 5) state dispatch
+ | "paragraph" ->
+ begin match PM.O.get state##.schema##.nodes "heading" with
+ | None -> Js._false
+ | Some t ->
+ let props = Js.some (object%js
+ val level = 1
+ end) in
+ PM.Commands.set_block_type pm t props state dispatch
+ end
+ | _ -> Js._false
+ end
+
+let handle_backspace pm state dispatch =
+
+ let res = PM.State.selection_to (state##.selection) in
+ match Js.Opt.to_option res##.nodeBefore with
+ | Some _ -> Js._false
+ | None -> (* Line start *)
+ begin match Jstr.to_string res##.parent##._type##.name with
+ | "heading" -> change_level pm res (-1) (fun x -> x <= 1) state dispatch
+ | _ -> Js._false
+ end
+
+
+let toggle_mark
+ : Js.regExp Js.t -> PM.t -> string -> PM.InputRule.input_rule Js.t
+ = fun regExp pm mark_type_name ->
+ PM.InputRule.create pm
+ regExp
+ ~fn:(Js.wrap_callback @@ fun (state:PM.State.editor_state Js.t) _ ~from ~to_ ->
+ match PM.O.get state##.schema##.marks mark_type_name with
+ | None -> Js.null
+ | Some mark_type ->
+
+ let m = state##.schema##mark_type mark_type Js.null in
+
+ (* Delete the markup code *)
+ let tr = (state##.tr)##delete ~from ~to_ in
+
+ (* Check if the mark is active at the position *)
+ let present = Js.Opt.bind
+ (PM.State.cursor (tr##.selection))
+ (fun resolved ->
+ Js.Opt.map
+ (mark_type##isInSet (resolved##marks ()))
+ (fun _ -> resolved)
+ ) in
+ Js.Opt.case present
+ (fun () ->
+ let tr = tr##addStoredMark m in
+ Js.some @@ tr)
+ (fun _resolved ->
+ let tr = tr##removeStoredMark_mark m in
+ Js.some tr))
+
+let input_rule pm =
+
+ let bold =
+ toggle_mark
+ (new%js Js.regExp (Js.string "\\*\\*$"))
+ pm
+ "strong"
+ and em =
+ toggle_mark
+ (new%js Js.regExp (Js.string "//$"))
+ pm
+ "em" in
+
+ PM.InputRule.to_plugin pm
+ (Js.array [| bold; em |])
+
+let default pm schema =
+
+ (** Load the history plugin *)
+ let _ = PM.History.(history pm (history_prop ()) ) in
+
+ let props = PM.Example.options schema in
+ props##.menuBar := Js.some Js._true;
+ props##.floatingMenu := Js.some Js._true;
+ let setup = PM.Example.example_setup pm props in
+
+ let keymaps =
+ PM.Keymap.keymap pm
+ [| "Backspace", (handle_backspace pm)
+ ; "#", (handle_sharp pm)
+ |] in
+
+ (* Add the custom keymaps in the list *)
+ let _ = setup##unshift keymaps in
+ let _ = setup##push (input_rule pm) in
+ let _ = setup##push (Tooltip.tooltip_plugin pm) in
+ let _ = setup##push (Tooltip.bold_plugin pm) in
+
+
+ Js.some setup
diff --git a/editor/prosemirror/bindings.ml b/editor/prosemirror/bindings.ml
index cb5a47c..4b95b73 100755
--- a/editor/prosemirror/bindings.ml
+++ b/editor/prosemirror/bindings.ml
@@ -92,7 +92,15 @@ module Model = struct
end
- type mark
+ class type mark = object ('this)
+
+ method eq:
+ 'this t -> bool t meth
+
+ method isInSet:
+ mark t js_array t -> mark t opt meth
+
+ end
type node_spec
@@ -100,6 +108,8 @@ module Model = struct
type slice
+ type depth = int opt
+
class type resolved_pos = object ('this)
method pos:
@@ -115,10 +125,13 @@ module Model = struct
node t readonly_prop
method node:
- int -> node t meth
+ depth -> node t meth
method index:
- int -> int meth
+ depth -> int meth
+
+ method after:
+ depth -> int meth
method nodeAfter:
node t opt readonly_prop
@@ -142,7 +155,7 @@ module Model = struct
and mark_spec = object ('this)
method toDOM:
- (node t -> domOutputSpec t) callback writeonly_prop
+ (node t -> domOutputSpec t) callback prop
method inclusive:
bool t prop
@@ -185,6 +198,9 @@ module Model = struct
method node:
Jstr.t -> < .. > t opt -> fragment t opt -> mark t js_array t opt -> node t meth
+ method mark_type:
+ mark_type t -> < .. > t opt -> mark t meth
+
end
and node_type = object ('this)
@@ -204,7 +220,7 @@ module Model = struct
content_match t readonly_prop
method hasRequiredAttrs:
- unit -> bool meth
+ unit -> bool t meth
method create_withFragment:
< .. > t -> fragment t opt -> mark t opt -> node t meth
@@ -226,6 +242,9 @@ module Model = struct
method spec:
mark_spec t readonly_prop
+ method isInSet:
+ mark t js_array t -> mark t opt meth
+
end
(** Common signature between fragment and node *)
@@ -245,7 +264,7 @@ module Model = struct
(** Get the child node at the given index, if it exists. *)
method eq:
- 'this t -> bool meth
+ 'this t -> bool t meth
(** Compare this element to another one. *)
method cut:
@@ -309,7 +328,7 @@ module Model = struct
mark t js_array t readonly_prop
method sameMarkupd:
- node t -> bool meth
+ node t -> bool t meth
method text:
Jstr.t opt prop
@@ -359,39 +378,97 @@ module Transform = struct
method step:
step t -> 'this t meth
+ method addMark:
+ from:int -> to_:int -> Model.mark t -> 'this t meth
+
+ method delete:
+ from:int -> to_:int -> 'this t meth
+
method insert:
- int -> Model.node t -> 'this t meth
+ pos:int -> Model.node t -> 'this t meth
method replaceRangeWith:
- int -> int -> Model.node t -> 'this t meth
+ from:int -> to_:int -> Model.node t -> 'this t meth
method setBlockType:
- int -> int -> Model.node_type t -> < .. > t -> 'this t meth
+ from:int -> to_:int -> Model.node_type t -> < .. > t -> 'this t meth
end
end
-(**
- The class is defined outside of the module View for prevent recursive
- declaration.
+module Classes = struct
-*)
-class type _editor_props = object ('this)
-end
+ (** View *)
+ class type editor_props = object ('this)
+ method editable:
+ (editor_state t -> bool t) callback prop
+ end
-module State = struct
+ and direct_editor_props = object ('this)
- class type plugin = object ('this)
+ inherit editor_props
- method props : _editor_props t readonly_prop
+ method state:
+ editor_state t writeonly_prop
+ (** The call back is called with this = instance of editor_view *)
+ method dispatchTransaction:
+ (editor_view t, transaction t -> unit) meth_callback writeonly_prop
end
- class type selection = object ('this)
+ and editor_view = object ('this)
+
+ method state:
+ editor_state t readonly_prop
+
+ method dom:
+ Brr.El.t readonly_prop prop
+
+ method editable:
+ bool t readonly_prop
+
+ method props:
+ direct_editor_props t readonly_prop
+
+ method update:
+ direct_editor_props t -> unit meth
+
+ method setProps:
+ direct_editor_props t -> unit meth
+
+ method updateState:
+ editor_state t -> unit meth
+
+ method posAtCoords:
+ < left: float prop ; top: float prop > t -> < pos: int prop; inside: int prop> t meth
+
+ method coordsAtPos:
+ int -> int opt -> < left: float prop; right: float prop; top: float prop; bottom: float prop > t meth
+
+ method dispatch:
+ transaction t -> unit meth
+
+ end
+
+ (** State *)
+
+ and plugin = object ('this)
+
+ method props : editor_props t opt prop
+
+ method view:
+ (editor_view t -> < .. > t) callback opt prop
+
+ method filterTransaction:
+ (transaction t -> editor_state t -> bool t) opt prop
+
+ end
+
+ and selection = object ('this)
method from:
int readonly_prop
@@ -399,6 +476,12 @@ module State = struct
method _to:
int readonly_prop
+ method empty:
+ bool t readonly_prop
+
+ method eq:
+ 'this t -> bool t meth
+
method content:
unit -> Model.slice t meth
@@ -474,13 +557,15 @@ module State = struct
method before:
Model.node t readonly_prop
+ method insertText:
+ Jstr.t -> from:int opt -> to_:int opt -> 'this t meth
+
method scrollIntoView :
unit -> 'this t meth
-
end
- class type configuration_prop = object ('this)
+ and configuration_prop = object ('this)
method schema:
Model.schema t opt prop
@@ -490,7 +575,7 @@ module State = struct
end
- class type creation_prop = object ('this)
+ and creation_prop = object ('this)
inherit configuration_prop
@@ -505,7 +590,7 @@ module State = struct
end
- class type editor_state = object ('this)
+ and editor_state = object ('this)
method doc :
Model.node t readonly_prop
@@ -538,45 +623,37 @@ module State = struct
end
-module View = struct
-
- class type editor_props = _editor_props
-
- class type direct_editor_props = object ('this)
-
- inherit editor_props
+module State = struct
- method state:
- State.editor_state t writeonly_prop
+ class type plugin = Classes.plugin
+ class type selection = Classes.selection
+ class type text_selection = Classes.text_selection
+ class type node_selection = Classes.node_selection
+ class type transaction = Classes.transaction
+ class type configuration_prop = Classes.configuration_prop
+ class type creation_prop = Classes.creation_prop
+ class type editor_state = Classes.editor_state
- (** The call back is called with this = instance of editor_view *)
- method dispatchTransaction:
- (editor_view t, State.transaction t -> unit) meth_callback writeonly_prop
+ type dispatch = (Classes.transaction t -> unit)
+end
- end
+module View = struct
- and editor_view = object ('this)
+ class type editor_props = Classes.editor_props
- method state:
- State.editor_state t readonly_prop
+ class type direct_editor_props = Classes.direct_editor_props
- method dom:
- Brr.El.t readonly_prop prop
+ class type editor_view = Classes.editor_view
- method editable:
- bool readonly_prop prop
+end
- method update:
- direct_editor_props t -> unit meth
+module History = struct
- method setProps:
- direct_editor_props t -> unit meth
+ class type history_prop = object ('this)
- method updateState:
- State.editor_state t -> unit meth
+ method depth: int opt prop
- method dispatch:
- State.transaction t -> unit meth
+ method newGroupDelay: int opt prop
end
@@ -633,18 +710,6 @@ module SchemaBasic = struct
end
-module History = struct
-
- class type history_prop = object ('this)
-
- method depth: int opt prop
-
- method newGroupDelay: int opt prop
-
- end
-
-end
-
module Example = struct
class type options = object ('this)
@@ -662,4 +727,5 @@ module Example = struct
bool t opt prop
end
+
end
diff --git a/editor/prosemirror/prosemirror.ml b/editor/prosemirror/prosemirror.ml
index e2758c7..e37cc3b 100755
--- a/editor/prosemirror/prosemirror.ml
+++ b/editor/prosemirror/prosemirror.ml
@@ -3,6 +3,8 @@ open Brr
type t = Jv.t
+type t' = t
+
let v
: unit -> t
= fun () ->
@@ -112,10 +114,6 @@ module State = struct
include Bindings.State
- type dispatch = (transaction Js.t -> unit)
-
- type command = editor_state Js.t -> dispatch Js.opt -> bool Js.t
-
let configuration_prop
: unit -> configuration_prop Js_of_ocaml.Js.t
= fun () -> Js_of_ocaml.Js.Unsafe.obj [||]
@@ -181,6 +179,10 @@ module State = struct
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")
end
(* Editor view *)
@@ -199,46 +201,37 @@ module View = struct
let editor_view
: t -> El.t -> direct_editor_props Js.t -> editor_view Js.t
= fun t node props ->
- let view = Jv.get t "view" in
- Jv.new' (Jv.get view "EditorView") [|Jv.Id.to_jv node ; Jv.Id.to_jv props|]
- |> 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.new' (Jv.get (Jv.get t "view") "EditorView") [|Jv.Id.to_jv node ; Jv.Id.to_jv props|]
|> Jv.Id.of_jv
end
-module SchemaBasic = struct
+module Commands = struct
- include Bindings.SchemaBasic
+ type t = State.editor_state Js.t -> State.dispatch Js.opt -> bool Js.t
- let schema
- : t -> Model.schema Js.t
+ let baseKeymap
+ : t' -> (string * t) array
= fun t ->
- Jv.get (Jv.get t "schema_basic") "schema"
+ Jv.get (Jv.get t "commands") "baseKeymap"
|> Jv.Id.of_jv
- let nodes
- : t -> nodes Js.t
- = fun t ->
- Jv.get (Jv.get t "schema_basic") "nodes"
+ 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
@@ -254,13 +247,13 @@ module History = struct
|> Jv.Id.of_jv
let undo
- : t -> State.command
+ : 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 -> State.command
+ : 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
@@ -269,7 +262,7 @@ end
module Keymap = struct
let keymap
- : t -> (string * State.command) array -> State.plugin Js.t
+ : 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|]
@@ -277,21 +270,61 @@ module Keymap = struct
end
-module Commands = struct
+module InputRule = struct
- let baseKeymap
- : t -> (string * State.command) array
+ 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 "commands") "baseKeymap"
+ Jv.get (Jv.get t "schema_basic") "schema"
|> Jv.Id.of_jv
- let set_block_type
- : t -> Model.node_type Js.t -> < .. > Js.t -> State.command
- = fun t node props ->
- Jv.call (Jv.get t "commands") "setBlockType" Jv.Id.[| to_jv node ; to_jv props |]
+ 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
+
(* Example Setup *)
module Example = struct
diff --git a/editor/prosemirror/prosemirror.mli b/editor/prosemirror/prosemirror.mli
index 7a723d3..eac895a 100755
--- a/editor/prosemirror/prosemirror.mli
+++ b/editor/prosemirror/prosemirror.mli
@@ -3,6 +3,8 @@ open Brr
type t
+type t' = t
+
val v
: unit -> t
@@ -57,13 +59,6 @@ module rec Model : sig
end
-and SchemaList : sig
-
- val 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
-
-end
-
(* State *)
and State : sig
@@ -100,9 +95,8 @@ and State : sig
val create_text_selection
: t -> Model.node Js.t -> int -> text_selection Js.t
- type dispatch = (transaction Js.t -> unit)
-
- type command = editor_state Js.t -> dispatch Js.opt -> bool Js.t
+ val cursor
+ : selection Js.t -> Model.resolved_pos Js.t Js.opt
end
@@ -126,16 +120,18 @@ and View : sig
end
-module SchemaBasic : sig
+module Commands : sig
- include module type of Bindings.SchemaBasic
+ type t = State.editor_state Js.t -> State.dispatch Js.opt -> bool Js.t
- val schema
- : t -> Model.schema Js.t
+ val baseKeymap
+ : t' -> (string * t) array
- val nodes
- : t -> nodes Js.t
+ val set_block_type
+ : t' -> Model.node_type Js.t -> < .. > Js.t Js.opt -> t
+ val toggle_mark
+ : t' -> Model.mark_type Js.t -> < .. > Js.t Js.opt -> t
end
@@ -150,26 +146,47 @@ module History : sig
: t -> history_prop Js.t -> State.plugin Js.t
val undo
- : t -> State.command
+ : t -> Commands.t
val redo
- : t -> State.command
+ : t -> Commands.t
end
module Keymap : sig
val keymap
- : t -> (string * State.command) array -> State.plugin Js.t
+ : t -> (string * Commands.t) array -> State.plugin Js.t
end
-module Commands : sig
+module InputRule : sig
- val baseKeymap
- : t -> (string * State.command) array
+ type input_rule
- val set_block_type
- : t -> Model.node_type Js.t -> < .. > Js.t -> State.command
+ (** Create a new input rule for the given regExp. *)
+ val 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
+
+ val to_plugin
+ : t -> input_rule Js.t Js.js_array Js.t -> State.plugin Js.t
+end
+
+module SchemaBasic : sig
+
+ include module type of Bindings.SchemaBasic
+
+ val schema
+ : t -> Model.schema Js.t
+
+ val nodes
+ : t -> nodes Js.t
+
+end
+
+module SchemaList : sig
+
+ val 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
end
diff --git a/editor/tooltip.ml b/editor/tooltip.ml
new file mode 100755
index 0000000..06426d1
--- /dev/null
+++ b/editor/tooltip.ml
@@ -0,0 +1,149 @@
+open StdLabels
+open Js_of_ocaml
+open Brr
+
+
+module PM = Prosemirror
+
+(** https://prosemirror.net/examples/tooltip/ *)
+
+(** Set the element position just above the selection *)
+let set_position
+ : PM.View.editor_view Js.t -> El.t -> unit
+ = fun view el ->
+ El.set_inline_style El.Style.display (Jstr.v "") el;
+ let start = view##coordsAtPos (view##.state##.selection##.from) Js.null
+ and end' = view##coordsAtPos (view##.state##.selection##._to) Js.null in
+ let offsetParent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv el) "offsetParent") in
+
+ let box = Jv.(Id.of_jv @@ call (Jv.Id.to_jv offsetParent) "getBoundingClientRect" [||]) in
+ let box_left = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "left") in
+ let box_bottom = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "bottom") in
+
+ let left = Float.max
+ ((start##.left +. end'##.left) /. 2.)
+ (start##.left +. 3.) in
+
+ El.set_inline_style (Jstr.v "left")
+ Jstr.( (of_float ( left -. box_left )) + (v "px") )
+ el;
+ El.set_inline_style (Jstr.v "bottom")
+ Jstr.( (of_float ( box_bottom -. start##.top )) + (v "px") )
+ el
+
+let tooltip
+ : PM.View.editor_view Js.t -> < .. > Js.t
+ = fun view ->
+
+ (* Create the element which will be displayed over the editor *)
+ let tooltip = El.div []
+ ~at:At.([class' (Jstr.v "tooltip")]) in
+ El.set_inline_style El.Style.display (Jstr.v "none") tooltip;
+
+ let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
+ let () = El.append_children parent [tooltip] in
+
+ let update
+ : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit
+ = fun view state_opt ->
+
+ Js.Opt.case state_opt
+ (fun () -> ())
+ (fun previous_state ->
+ if ((view##.state##.doc##eq previous_state##.doc) = Js._true)
+ && ((previous_state##.selection##eq view##.state##.selection) = Js._true)
+ then
+ ()
+ else (
+ if (view##.state##.selection##.empty) = Js._true then
+ (* Hide the tooltip if the selection is empty *)
+ El.set_inline_style El.Style.display (Jstr.v "none") tooltip
+ else (
+ (* otherwise, reposition it and update its content *)
+ set_position view tooltip;
+ El.set_prop
+ (El.Prop.jstr (Jstr.v "textContent"))
+ (Jstr.of_int
+ (view##.state##.selection##._to - view##.state##.selection##.from))
+ tooltip)))
+ and destroy () = El.remove tooltip in
+
+ object%js
+ val update = Js.wrap_callback update
+ val destroy= Js.wrap_callback destroy
+ end
+
+let tooltip_plugin
+ : PM.t -> PM.State.plugin Js.t
+ = fun t ->
+ let state = Jv.get (Jv.Id.to_jv t) "state" in
+
+ let params = object%js
+ val view = (fun view -> tooltip view)
+ end in
+
+ Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |]
+ |> Jv.Id.of_jv
+
+
+let boldtip
+ : PM.View.editor_view Js.t -> < .. > Js.t
+ = fun view ->
+ (* Create the element which will be displayed over the editor *)
+ let tooltip = El.div []
+ ~at:At.([class' (Jstr.v "tooltip")]) in
+ El.set_inline_style El.Style.display (Jstr.v "none") tooltip;
+
+ let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
+ let () = El.append_children parent [tooltip] in
+
+ let update
+ : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit
+ = fun view _state_opt ->
+ let state = view##.state in
+ let is_bold = match PM.O.get state##.schema##.marks "strong" with
+ | None -> None
+ | Some mark_type ->
+ let is_strong = Js.Opt.bind state##.storedMarks (fun t -> mark_type##isInSet t) in
+ Js.Opt.case is_strong
+ (fun () -> None)
+ (fun _ -> Some (Jstr.v "gras")) in
+ let is_em = match PM.O.get state##.schema##.marks "em" with
+ | None -> None
+ | Some mark_type ->
+ let is_strong = Js.Opt.bind state##.storedMarks (fun t -> mark_type##isInSet t) in
+ Js.Opt.case is_strong
+ (fun () -> None)
+ (fun _ -> Some (Jstr.(v "emphase"))) in
+
+ let marks = List.filter_map [is_bold ; is_em]
+ ~f:(fun x -> x) in
+
+ match marks with
+ | [] -> El.set_inline_style El.Style.display (Jstr.v "none") tooltip
+ | _ ->
+ (* The mark is present, add in the content *)
+ set_position view tooltip;
+ El.set_prop
+ (El.Prop.jstr (Jstr.v "textContent"))
+ (Jstr.concat marks ~sep:(Jstr.v ", "))
+ tooltip
+
+ and destroy () = El.remove tooltip in
+
+ object%js
+ val update = Js.wrap_callback update
+ val destroy= Js.wrap_callback destroy
+ end
+
+let bold_plugin
+ : PM.t -> PM.State.plugin Js.t
+ = fun t ->
+ let state = Jv.get (Jv.Id.to_jv t) "state" in
+
+ let params = object%js
+ val view = (fun view -> boldtip view)
+ end in
+
+ Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |]
+ |> Jv.Id.of_jv