diff options
Diffstat (limited to 'editor/plugins')
| -rwxr-xr-x | editor/plugins/dune | 9 | ||||
| -rwxr-xr-x | editor/plugins/footnotes.ml | 248 | ||||
| -rwxr-xr-x | editor/plugins/link_editor.ml | 127 | ||||
| -rwxr-xr-x | editor/plugins/plugins.ml | 137 | ||||
| -rwxr-xr-x | editor/plugins/popin.ml | 83 | ||||
| -rwxr-xr-x | editor/plugins/tooltip.ml | 89 | 
6 files changed, 693 insertions, 0 deletions
| diff --git a/editor/plugins/dune b/editor/plugins/dune new file mode 100755 index 0000000..046dc5a --- /dev/null +++ b/editor/plugins/dune @@ -0,0 +1,9 @@ +(library + (name plugins) + (libraries  +   brr +   prosemirror +   js_lib +   ) + (preprocess (pps js_of_ocaml-ppx)) + ) diff --git a/editor/plugins/footnotes.ml b/editor/plugins/footnotes.ml new file mode 100755 index 0000000..794171f --- /dev/null +++ b/editor/plugins/footnotes.ml @@ -0,0 +1,248 @@ +open Brr +open Js_of_ocaml +module PM = Prosemirror + +let footNoteSpec = object%js + +  val mutable group = Jstr.v "inline" +  val mutable content = Jstr.v "inline*" (* The star is very important ! *) +  val mutable inline = Js._true +  val mutable draggable = Js._true +  (*  This makes the view treat the node as a leaf, even though it +      technically has content *) +  val mutable atom = Js._true + +  val toDOM +    : (PM.Model.node Js.t -> PM.Model.domOutputSpec Js.t) Js.callback +    = Js.wrap_callback (fun _ -> +        let open PM.Model.Dom_output_spec in +        v "footnote" +          [ hole ]) + +  val parseDOM +    : PM.Model.parse_rule Js.t Js.js_array Js.t Js.opt +    = Js.some @@ Js.array +      [|PM.Model.ParseRule.tag (Jstr.v "footnote")|] + +end + +let footnote_schema pm defaultSchema = + +  let nodes = defaultSchema##.spec##.nodes +  and marks = defaultSchema##.spec##.marks in + +  let specs = PM.Model.schema_spec +      (nodes##addToEnd (Jstr.v "footnote") (Js.Unsafe.coerce footNoteSpec)) +      (Some marks) +      None in + +  PM.Model.schema pm +    specs + +let build_menu pm schema = +  let menu = PM.Example.buildMenuItems pm schema in + +  let itemSpec = PM.Menu.menuItemSpec () in +  itemSpec##.title := Js.some @@ Jstr.v "Insert footnote"; +  itemSpec##.label := Js.some @@ Jstr.v "Footnote"; +  itemSpec##.select := Js.wrap_meth_callback (fun _ (state:PM.State.editor_state Js.t) -> +      match PM.O.get schema##.nodes "footnote" with +      | None ->  Js._false +      | Some footnote_node -> +        let res = Js.Opt.test @@ PM.Transform.insertPoint +            pm +            state##.doc +            ~pos:state##.selection##.from +            footnote_node +        in +        Js.bool res); + +  itemSpec##.run := +    Js.wrap_meth_callback (fun _this state dispatch _ _ -> +        match PM.O.get schema##.nodes "footnote" with +        | None -> () +        | Some footnote_node -> + +          let from' = PM.State.selection_from state##.selection +          and to' = PM.State.selection_to state##.selection in + +          let content = +            if state##.selection##.empty != Js._true +            && from'##sameParent to' = Js._true +            && from'##.parent##.inlineContent = Js._true then ( +              from'##.parent##.content##cut +                (from'##.parentOffset) +                (Js.some @@ to'##.parentOffset) +            ) else ( +              PM.Model.empty_fragment pm +            ) in +          let new_node = footnote_node##create_withFragmentContent +              Js.null +              (Js.some content) +              Js.null +          in +          dispatch @@ +          state##.tr##replaceSelectionWith +            new_node +            Js.null +      ); + +  let item = PM.Menu.menu_item pm itemSpec in +  let _ = menu##.insertMenu##.content##push item in +  menu + +let fromOutside +  : bool PM.State.meta_data Js.t +  = PM.State.create_str_meta_data (Jstr.v "fromOutside") + +let footnote_view +  : PM.t -> PM.Model.node Js.t -> PM.View.editor_view Js.t -> (unit -> int) -> < .. > Js.t +  = fun pm init_node outerView get_pos -> + +    (* These are used when the footnote is selected *) +    let innerView +      : PM.View.editor_view Js.t Js.opt ref +      = ref Js.null in + +    let dispatchInner +      : PM.View.editor_view Js.t -> PM.State.transaction Js.t -> unit +      = fun view tr -> +        let res = view##.state##applyTransaction tr in +        view##updateState res##.state; + +        let meta = Js.Optdef.get (tr##getMeta fromOutside) (fun () -> false) in +        if (not meta) then ( +          let outerTr = outerView##.state##.tr +          and offsetMap = PM.Transform.offset pm ((get_pos()) + 1) in +          res##.transactions##forEach +            (Js.wrap_callback @@ +             fun (elem:PM.State.transaction Js.t) _ _ -> +             elem##.steps##forEach +               (Js.wrap_callback @@ fun (step:PM.Transform.step Js.t) _ _ -> +                let _ = outerTr##step (step##map offsetMap) in +                () +               )); +          if (outerTr##.docChanged = Js._true) then ( +            outerView##dispatch outerTr) +        ); +    in +    object%js (_self) + +      val mutable node: PM.Model.node Js.t = init_node + +      (* The node's representation in the editor (empty, for now) *) +      val dom = El.v (Jstr.v "footnote") [] + +      method _open = +        (* Append a tooltip to the outer node *) +        let tooltip = El.div [] +            ~at:At.([class' (Jstr.v "popin")]) in +        El.append_children _self##.dom +          [ tooltip ]; + +        let dispatch_fn +          : PM.State.transaction Js.t -> unit +          = fun tr -> outerView##dispatch tr in + +        let state_properties = Js.Unsafe.coerce (object%js +            val doc = Js.some _self##.node; +            val plugins = Js.some @@ Js.array @@ [| +                PM.Keymap.keymap pm +                  [| ( "Mod-z" +                     , (fun _ _ -> PM.History.undo pm outerView##.state (Js.some dispatch_fn))) +                   ; ( "Mod-y" +                     , (fun _ _ -> PM.History.redo pm outerView##.state (Js.some dispatch_fn))) +                  |] +              |]; +          end) in + +        let view_properties = PM.View.direct_editor_props () in +        view_properties##.state := PM.State.create pm state_properties; +        (* This is the magic part *) +        view_properties##.dispatchTransaction := +          (Js.wrap_meth_callback dispatchInner); +        view_properties##.handleDOMEvents := PM.O.init +            [| ( "mousedown" +               , Js.wrap_callback (fun _ _ -> +                     (* Kludge to prevent issues due to the fact that the +                        whole footnote is node-selected (and thus DOM-selected) +                        when the parent editor is focused. *) +                     if (outerView##hasFocus () = Js._true) then ( +                       Js.Opt.iter !innerView (fun view -> view##focus ()) +                     ); +                     Js._false ))|]; + +        innerView := Js.some +            (PM.View.editor_view pm +               tooltip +               view_properties); + +      method close = +        Js.Opt.iter (!innerView) +          (fun view -> +             view##destroy; +             innerView := Js.null; +             El.set_prop +               (El.Prop.jstr (Jstr.v "textContent")) +               (Jstr.empty) +               _self##.dom +          ) + +      method update +        : PM.Model.node Js.t -> bool Js.t +        = fun node -> +          if (node##sameMarkup _self##.node = Js._false) then ( +            Js._false +          ) else ( +            _self##.node := node; +            Js.Opt.iter !innerView (fun view -> +                let state = view##.state in +                Js.Opt.iter (node##.content##findDiffStart state##.doc##.content) (fun start -> +                    let res_opt = (node##.content##findDiffEnd state##.doc##.content) in +                    Js.Opt.iter res_opt (fun end_diff -> +                        let overlap = start - (min end_diff##.a end_diff##.b) in +                        let endA, endB = +                          if overlap > 0 then +                            ( end_diff##.a + overlap +                            , end_diff##.b + overlap ) +                          else +                            ( end_diff##.a +                            , end_diff##.b ) +                        in +                        let tr = +                          state##.tr +                          ##(replace +                               ~from:start +                               ~to_:endB +                               (Js.some @@ node##slice ~from:start ~to_:(Js.some endA))) +                          ##(setMeta fromOutside true) in +                        view##dispatch tr))); +            Js._true +          ) + +      method destroy = +        Js.Opt.iter !innerView (fun _ -> _self##close) + +      method stopEvent e = +        Js.Opt.case !innerView +          (fun () -> Js._false) +          (fun view -> +             let dom = view##.dom in +             Jv.call (Jv.Id.to_jv dom) "contains" [| e##.target|] +             |> Jv.Id.of_jv) + +      method ignoreMutation = +        Js._true + +      method selectNode = +        El.set_class (Jstr.v "ProseMirror-selectednode") true _self##.dom; +        if not (Js.Opt.test !innerView) then ( +          _self##_open +        ) + +      method deselectNode = +        El.set_class (Jstr.v "ProseMirror-selectednode") false _self##.dom; +        if (Js.Opt.test !innerView) then +          _self##close + +    end diff --git a/editor/plugins/link_editor.ml b/editor/plugins/link_editor.ml new file mode 100755 index 0000000..9bfdfd4 --- /dev/null +++ b/editor/plugins/link_editor.ml @@ -0,0 +1,127 @@ +open Brr + +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +let link_edit +  : PM.View.editor_view Js.t -> < .. > Js.t +  = fun view -> + +    let popin = El.div [] +        ~at:At.([class' (Jstr.v "popin")]) in + +    El.set_inline_style El.Style.display (Jstr.v "none") popin; + +    let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in +    let () = El.append_children parent [popin] in + +    let hide +      : unit -> unit +      = fun () -> +        El.set_inline_style El.Style.display (Jstr.v "none") popin +    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 +        Js.Opt.case (state##.doc##nodeAt (view##.state##.selection##._to)) +          (fun () -> hide ()) +          (fun node -> +             (* Check if we are editing a link *) +             match PM.O.get state##.schema##.marks "link" with +             | None -> () +             | Some link_type -> +               let is_present = link_type##isInSet node##.marks in +               Js.Opt.case +                 is_present +                 (fun () -> hide ()) +                 (fun mark -> +                    (* Get the node's bounding position and display the popin *) +                    let position = state##.doc##resolve +                        (view##.state##.selection##._to) in +                    let start = position##start Js.null +                    and end' = position##_end Js.null in + +                    Popin.set_position +                      ~start +                      ~end' +                      view popin; + +                    (* Extract the value from the attribute *) +                    let attrs = mark##.attrs in +                    let href_opt = PM.O.get attrs "href" in +                    let href_value = Option.value +                        ~default:Jstr.empty +                        href_opt +                    in + +                    (* Create the popin content *) +                    let a = El.a +                        ~at:At.[ href href_value ] +                        [ El.txt href_value ] in + +                    let entry = Popin.build_field a +                        (fun new_value -> +                           (* The function is called when the user validate +                              the change in the popi. We create a new +                              transaction in the document by replacing the +                              mark with the new one. *) +                           if not (Jstr.equal new_value href_value) then ( + +                             (* Create a new attribute object for the mark in +                                order to keep history safe *) +                             let attrs' = PM.O.init +                                 [| "href", new_value |] in + +                             Option.iter +                               (fun v -> PM.O.set attrs' "title" v) +                               (PM.O.get attrs "title"); + +                             let mark' = state##.schema##mark_fromType +                                 link_type +                                 (Js.some attrs') in +                             (* Create a transaction which update the +                                mark with the new value *) +                             view##dispatch +                               state +                               ##.tr +                               ##(removeMark +                                    ~from:start +                                    ~to_:end' +                                    mark) +                               ##(addMark +                                    ~from:start +                                    ~to_:end' +                                    mark') +                           ); +                           true + +                        ) in + + +                    El.set_children popin +                      [ entry.field +                      ; entry.button ]; + +                 )) + +    and destroy () = El.remove popin in + +    object%js +      val update = Js.wrap_callback update +      val destroy= Js.wrap_callback destroy +    end + +let 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 -> link_edit view) +    end in + +    Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |] +    |> Jv.Id.of_jv diff --git a/editor/plugins/plugins.ml b/editor/plugins/plugins.ml new file mode 100755 index 0000000..3a92df8 --- /dev/null +++ b/editor/plugins/plugins.ml @@ -0,0 +1,137 @@ +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +module Footnotes = Footnotes + +(** 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_fromType 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; +  props##.menuContent := (Footnotes.build_menu pm schema)##.fullMenu; +  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.bold_plugin pm) in +  let _ = setup##push (Link_editor.plugin pm) in + + +  Js.some setup diff --git a/editor/plugins/popin.ml b/editor/plugins/popin.ml new file mode 100755 index 0000000..63dcad1 --- /dev/null +++ b/editor/plugins/popin.ml @@ -0,0 +1,83 @@ +open Brr +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +type binded_field = +  { field: El.t +  ; button: El.t +  } + +(** Set the element position just above the selection  *) +let set_position +  : start:int -> end':int -> PM.View.editor_view Js.t -> El.t -> unit +  = fun ~start ~end' view el -> +    El.set_inline_style El.Style.display (Jstr.v "") el; + +    (* These are in screen coordinates *) +    let start = view##coordsAtPos start Js.null +    and end' = view##coordsAtPos end' Js.null in +    let offsetParent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv el) "offsetParent") in + +    (* The box in which the tooltip is positioned, to use as base *) +    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 + +    (* Find a center-ish x position from the selection endpoints (when +       crossing lines, end may be more to the left) *) +    let left = (start##.left +. end'##.left) /. 2. 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 + +(** Build a button which allow to activate or desactivate the given Element. + +    The function f is called when the user validate the input. + +*) +let build_field +  : El.t -> (Jstr.t -> bool) -> binded_field +  = fun field f -> + +    let button_content = +      [ El.i [] +          ~at:At.[ class' (Jstr.v "fas") +                 ; class' (Jstr.v "fa-pen") ] +      ] in + +    let button = El.button +        button_content +    in + +    Ev.listen Ev.click +      (fun _ -> +         match El.at (Jstr.v "contenteditable") field with +         | Some value when (Jstr.equal value (Jstr.v "true")) -> +           let new_value = El.prop +               (El.Prop.jstr (Jstr.v "textContent")) +               field in +           begin match f new_value with +             | true -> +               El.set_at (Jstr.v "contenteditable") None field; +               El.set_children button button_content +             | false -> () +           end +         | _ -> +           El.set_at (Jstr.v "contenteditable") +             (Some (Jstr.v "true")) field; +           El.set_children button +             [ El.i +                 ~at:At.[ class' (Jstr.v "fas") +                        ; class' (Jstr.v "fa-check") ] +                 [] +             ] +      ) +      (El.as_target button); + +    { field +    ; button = button +    } diff --git a/editor/plugins/tooltip.ml b/editor/plugins/tooltip.ml new file mode 100755 index 0000000..05d56d4 --- /dev/null +++ b/editor/plugins/tooltip.ml @@ -0,0 +1,89 @@ +open StdLabels +open Brr + +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +(** https://prosemirror.net/examples/tooltip/ *) + + +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 "popin") +                ]) 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 -> + +        (* Compare the previous and actual state. If the stored marks are the +           same, just return *) +        let state = view##.state in +        let previous_stored_marks = +          Js.Opt.bind state_opt (fun state -> state##.storedMarks) +          |> Js.Opt.to_option +        and current_stored_marks = state##.storedMarks in + +        let same = match previous_stored_marks, Js.Opt.to_option current_stored_marks with +          | Some arr1, Some arr2 -> +            Js_lib.Array.compare arr1 arr2 ~f:(fun v1 v2 -> v1##eq v2) +          | None, None -> Js._true +          | _, _ -> Js._false in + +        if same <> Js._true then + +          let is_bold = Option.bind (PM.O.get state##.schema##.marks "strong") +              (fun mark_type -> +                 let is_strong = +                   Js.Opt.bind current_stored_marks +                     (fun t -> mark_type##isInSet t) in +                 Js.Opt.case is_strong +                   (fun () -> None) +                   (fun _ -> Some (Jstr.v "gras"))) in +          let is_em = Option.bind (PM.O.get state##.schema##.marks "em") +              (fun mark_type -> +                 let is_em = +                   Js.Opt.bind current_stored_marks +                     (fun t -> mark_type##isInSet t) in +                 Js.Opt.case is_em +                   (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 *) +            let start = view##.state##.selection##.from +            and end' = view##.state##.selection##._to in +            Popin.set_position ~start ~end' 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 | 
