Markdown Projectors

src/haz3lcore/dune

@@ -2,7 +2,7 @@
 
 (library
  (name haz3lcore)
- (libraries util sexplib unionFind uuidm virtual_dom yojson core)
+ (libraries util sexplib unionFind uuidm virtual_dom yojson core omd)
  (js_of_ocaml)
  (instrumentation
   (backend bisect_ppx))

src/haz3lcore/tiles/Base.re

@@ -10,7 +10,8 @@ type kind =
   | Checkbox
   | Slider
   | SliderF
-  | TextArea;
+  | TextArea
+  | Markdown;
 
 [@deriving (show({with_path: false}), sexp, yojson)]
 type segment = list(piece)

src/haz3lcore/zipper/Projector.re

@@ -12,6 +12,7 @@ let to_module = (kind: Base.kind): (module Cooked) =>
   | SliderF => (module Cook(SliderFProj.M))
   | Checkbox => (module Cook(CheckboxProj.M))
   | TextArea => (module Cook(TextAreaProj.M))
+  | Markdown => (module Cook(MarkdownProj.M))
   };
 
 let shape = (p: Base.projector, info: info): shape => {

src/haz3lcore/zipper/ProjectorBase.re

@@ -83,7 +83,8 @@ module type Projector = {
       model,
       ~info: info,
       ~local: action => Ui_effect.t(unit),
-      ~parent: external_action => Ui_effect.t(unit)
+      ~parent: external_action => Ui_effect.t(unit),
+      ~font_metrics: FontMetrics.t
     ) =>
     Node.t;
   /* How much space should be left in the code view for
@@ -123,12 +124,13 @@ module Cook = (C: Projector) : Cooked => {
   let init = C.init |> serialize_m;
   let can_project = C.can_project;
   let can_focus = C.can_focus;
-  let view = (m, ~info, ~local, ~parent) =>
+  let view = (m, ~info, ~local, ~parent, ~font_metrics) =>
     C.view(
       deserialize_m(m),
       ~info,
       ~local=a => local(serialize_a(a)),
       ~parent,
+      ~font_metrics,
     );
   let placeholder = m =>
     m |> Sexplib.Sexp.of_string |> C.model_of_sexp |> C.placeholder;

src/haz3lcore/zipper/projectors/CheckboxProj.re

@@ -25,7 +25,13 @@ let put = (bool: bool): Piece.t => bool |> string_of_bool |> mk_mono(Exp);
 let toggle = (piece: Piece.t) => put(!get(piece));
 
 let view =
-    (_, ~info, ~local as _, ~parent: external_action => Ui_effect.t(unit)) =>
+    (
+      _,
+      ~info,
+      ~local as _,
+      ~parent: external_action => Ui_effect.t(unit),
+      ~font_metrics as _,
+    ) =>
   Node.input(
     ~attrs=
       [

src/haz3lcore/zipper/projectors/FoldProj.re

@@ -13,7 +13,7 @@ module M: Projector = {
   let can_focus = false;
   let placeholder = (_, _) => Inline(2);
   let update = (_, _) => ();
-  let view = (_, ~info as _, ~local as _, ~parent) =>
+  let view = (_, ~info as _, ~local as _, ~parent, ~font_metrics as _) =>
     div(
       ~attrs=[Attr.on_double_click(_ => parent(Remove))],
       [text("⋱")],

src/haz3lcore/zipper/projectors/InfoProj.re

@@ -76,7 +76,7 @@ module M: Projector = {
     | (ToggleDisplay, Self) => Expected
     };
 
-  let view = (model, ~info, ~local, ~parent as _) =>
+  let view = (model, ~info, ~local, ~parent as _, ~font_metrics as _) =>
     div(
       ~attrs=[
         Attr.classes(["info", "code"]),

src/haz3lcore/zipper/projectors/MarkdownProj.re

@@ -0,0 +1,128 @@
+open Util;
+open Virtual_dom.Vdom;
+open ProjectorBase;
+
+let of_id = (id: Id.t) =>
+  "id" ++ (id |> Id.to_string |> String.sub(_, 0, 8));
+
+let of_mono = (syntax: Piece.t): option(string) =>
+  switch (syntax) {
+  | Tile({label: [l], _}) => Some(StringUtil.unescape_linebreaks(l))
+  | _ => None
+  };
+
+let mk_mono = (sort: Sort.t, string: string): Piece.t =>
+  string
+  |> StringUtil.escape_linebreaks
+  |> Form.mk_atomic(sort)
+  |> Piece.mk_tile(_, []);
+
+let get = (piece: Piece.t): string =>
+  switch (piece |> of_mono) {
+  | None => failwith("TextArea: not string literal")
+  | Some(s) => s
+  };
+
+let put = (s: string): Piece.t => s |> mk_mono(Exp);
+
+let put = (str: string): external_action =>
+  SetSyntax(str |> Form.string_quote |> put);
+
+let is_last_pos = id =>
+  Web.TextArea.caret_at_end(Web.TextArea.get(of_id(id)));
+let is_first_pos = id =>
+  Web.TextArea.caret_at_start(Web.TextArea.get(of_id(id)));
+
+let key_handler = (id, ~parent, evt) => {
+  open Effect;
+  let key = Key.mk(KeyDown, evt);
+
+  switch (key.key) {
+  | D("ArrowRight" | "ArrowDown") when is_last_pos(id) =>
+    JsUtil.get_elem_by_id(of_id(id))##blur;
+    Many([parent(Escape(Right)), Stop_propagation]);
+  | D("ArrowLeft" | "ArrowUp") when is_first_pos(id) =>
+    JsUtil.get_elem_by_id(of_id(id))##blur;
+    Many([parent(Escape(Left)), Stop_propagation]);
+  /* Defer to parent editor undo for now */
+  | D("z" | "Z" | "y" | "Y") when Key.ctrl_held(evt) || Key.meta_held(evt) =>
+    Many([Prevent_default])
+  | D("z" | "Z")
+      when Key.shift_held(evt) && (Key.ctrl_held(evt) || Key.meta_held(evt)) =>
+    Many([Prevent_default])
+  | D("\"") =>
+    /* Hide quotes from both the textarea and parent editor */
+    Many([Prevent_default, Stop_propagation])
+  | _ => Stop_propagation
+  };
+};
+
+let safe_html_to_node = (html_string: string): Node.t =>
+  Node.div(~attrs=[Attr.create("innerHTML", html_string)], []);
+let textarea =
+    (
+      id,
+      ~parent as _: external_action => Ui_effect.t(unit),
+      ~font_metrics: FontMetrics.t,
+      text: string,
+    ) => {
+  let foo = Omd.of_string(text);
+  let bar = Omd.to_html(foo);
+  let size =
+    Css_gen.concat([
+      Css_gen.overflow(`Auto),
+      Css_gen.height(`Px(int_of_float(30. *. font_metrics.row_height))),
+      Css_gen.width(`Px(int_of_float(150. *. font_metrics.col_width))),
+    ]);
+  // Node.innerHtml(bar);
+  let foo =
+    Node.inner_html(
+      ~attrs=[Attr.id(of_id(id)), Attr.style(size)],
+      ~this_html_is_sanitized_and_is_totally_safe_trust_me=bar, // ;)
+      ~tag="div",
+    );
+  foo();
+};
+
+let view = (_, ~info, ~local as _, ~parent, ~font_metrics) => {
+  let text = info.syntax |> get |> Form.strip_quotes;
+  Node.div(
+    ~attrs=[Attr.classes(["wrapper"])],
+    [
+      Node.div(
+        ~attrs=[Attr.classes(["cols", "code"])],
+        [Node.text("·")]
+        @ [textarea(info.id, ~parent, ~font_metrics, text)],
+      ),
+    ],
+  );
+};
+
+module M: Projector = {
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type model = unit;
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type action = unit;
+  let init = ();
+  let can_project = _ => true; //TODO(andrew): restrict somehow
+  let can_focus = true;
+  let placeholder = (_, _info) => {
+    Block({
+      row: 30,
+      /* +2 for left and right padding */
+      col: 150,
+    });
+  };
+  let update = (model, _) => model;
+  let view = view;
+  let focus = ((id: Id.t, d: option(Direction.t))) => {
+    JsUtil.get_elem_by_id(of_id(id))##focus;
+    switch (d) {
+    | None => ()
+    | Some(Left) =>
+      Web.TextArea.set_caret_to_start(Web.TextArea.get(of_id(id)))
+    | Some(Right) =>
+      Web.TextArea.set_caret_to_end(Web.TextArea.get(of_id(id)))
+    };
+  };
+};

src/haz3lcore/zipper/projectors/SliderFProj.re

@@ -27,7 +27,13 @@ module M: Projector = {
   let placeholder = (_, _) => Inline(10);
   let update = (model, _) => model;
   let view =
-      (_, ~info, ~local as _, ~parent: external_action => Ui_effect.t(unit)) =>
+      (
+        _,
+        ~info,
+        ~local as _,
+        ~parent: external_action => Ui_effect.t(unit),
+        ~font_metrics as _,
+      ) =>
     Util.Web.range(
       ~attrs=[Attr.on_input((_, v) => parent(SetSyntax(put(v))))],
       get(info.syntax) |> Printf.sprintf("%.2f"),

src/haz3lcore/zipper/projectors/SliderProj.re

@@ -24,7 +24,13 @@ module M: Projector = {
   let placeholder = (_, _) => Inline(10);
   let update = (model, _) => model;
   let view =
-      (_, ~info, ~local as _, ~parent: external_action => Ui_effect.t(unit)) =>
+      (
+        _,
+        ~info,
+        ~local as _,
+        ~parent: external_action => Ui_effect.t(unit),
+        ~font_metrics as _,
+      ) =>
     Util.Web.range(
       ~attrs=[Attr.on_input((_, v) => parent(SetSyntax(put(v))))],
       get(info.syntax),

src/haz3lcore/zipper/projectors/TextAreaProj.re

@@ -77,7 +77,7 @@ let textarea =
     [],
   );
 
-let view = (_, ~info, ~local as _, ~parent) => {
+let view = (_, ~info, ~local as _, ~parent, ~font_metrics as _) => {
   let text = info.syntax |> get |> Form.strip_quotes;
   Node.div(
     ~attrs=[Attr.classes(["wrapper"])],

src/haz3lweb/view/ProjectorView.re

@@ -20,6 +20,7 @@ let name = (p: kind): string =>
   | Slider => "slider"
   | SliderF => "sliderf"
   | TextArea => "text"
+  | Markdown => "markdown"
   };
 
 /* This must be updated and kept 1-to-1 with the above
@@ -33,6 +34,7 @@ let of_name = (p: string): kind =>
   | "slider" => Slider
   | "sliderf" => SliderF
   | "text" => TextArea
+  | "markdown" => Markdown
   | _ => failwith("Unknown projector kind")
   };
 
@@ -144,7 +146,7 @@ let setup_view =
     ~info,
     ~selected=List.mem(id, meta.syntax.selection_ids),
     p,
-    P.view(p.model, ~info, ~local, ~parent),
+    P.view(p.model, ~font_metrics, ~info, ~local, ~parent),
   );
 };
 
@@ -214,7 +216,7 @@ module Panel = {
       | Exp(Float)
       | Pat(Float) => [SliderF]
       | Exp(String)
-      | Pat(String) => [TextArea]
+      | Pat(String) => [TextArea, Markdown]
       | _ => []
       }
     )

src/haz3lweb/view/dec/CaretDec.re

@@ -1,4 +1,5 @@
 open Util;
+open Haz3lcore;
 
 module Profile = {
   type t = {

src/haz3lweb/view/dec/CaretPosDec.re

@@ -1,4 +1,5 @@
 open Virtual_dom.Vdom;
+open Haz3lcore;
 
 module Profile = {
   type style = [ | `Sibling];

src/haz3lweb/view/dec/DecUtil.re

@@ -1,7 +1,7 @@
 open Virtual_dom.Vdom;
 open Node;
 open Util;
-
+open Haz3lcore;
 let caret_width = 0.2;
 
 let tip_width = 0.32;

src/haz3lweb/view/dhcode/Decoration_common.re

@@ -1,5 +1,5 @@
 open Virtual_dom.Vdom;
-
+open Haz3lcore;
 module MeasuredPosition = Pretty.MeasuredPosition;
 module MeasuredLayout = Pretty.MeasuredLayout;