HTML Projector

src/haz3lcore/projectors/HazelDOM.re

@@ -0,0 +1,150 @@
+open Virtual_dom.Vdom;
+open Util;
+open Language;
+open IdTagged.FreshGrammar;
+
+[@deriving (show({with_path: false}), sexp, yojson)]
+type t = {
+  model: DHExp.t,
+  inject: DHExp.t => Ui_effect.t(unit),
+  view_term: DHExp.t => Node.t,
+};
+
+let input_type_mappings: list((string, string)) = [
+  ("Button", "button"),
+  ("Checkbox", "checkbox"),
+  ("Radio", "radio"),
+  ("Range", "range"),
+];
+
+let of_constructor = (d: DHExp.t): option((string, DHExp.t)) =>
+  switch (d.term) {
+  | Ap(Forward, {term: Constructor(name, _), _}, body) =>
+    Some((name, body))
+  | _ => None
+  };
+
+let of_pair = (d: DHExp.t): option((string, string)) =>
+  switch (d.term) {
+  | Parens({
+      term:
+        Tuple([{term: Atom(String(k)), _}, {term: Atom(String(v)), _}]),
+      _,
+    }) =>
+    Some((k, v))
+  | Tuple([{term: Atom(String(k)), _}, {term: Atom(String(v)), _}]) =>
+    Some((k, v))
+  | _ => None
+  };
+
+let render_style_attr = (d: DHExp.t): option(string) =>
+  switch (of_pair(d)) {
+  | Some((name, value)) => Some(name ++ ": " ++ value)
+  | _ => None
+  };
+
+let render_styles = styles =>
+  styles
+  |> List.filter_map(render_style_attr)
+  |> String.concat(";")
+  |> Attr.create("style");
+
+// copy-pasted from CLI/Run.re
+let evaluate = exp =>
+  fst(
+    Evaluator.evaluate(
+      ~env=Builtins.env_init,
+      fst(
+        Elaborator.elaborate(
+          Statics.mk(CoreSettings.on, Builtins.ctx_init(Some(Int)), exp),
+          exp,
+        ),
+      ),
+    ),
+  );
+
+let on_ = (mvu: t, handler, _evt) => {
+  let new_model = evaluate(Exp.ap(Forward, handler, mvu.model));
+  Effect.Many([Effect.Stop_propagation, mvu.inject(new_model)]);
+};
+
+let on_input = (mvu: t, handler, _evt, arg) => {
+  let new_model =
+    evaluate(
+      Exp.ap(Forward, handler, Exp.tuple([mvu.model, Exp.string(arg)])),
+    );
+  Effect.Many([Effect.Stop_propagation, mvu.inject(new_model)]);
+};
+
+let render_attr = (mvu: t, d: DHExp.t): Attr.t => {
+  let attr_err = (d: DHExp.t) => {
+    prerr_endline("render_attr: " ++ DHExp.show(d));
+    Attr.empty;
+  };
+  switch (of_constructor(d)) {
+  | Some(x) =>
+    switch (x) {
+    | ("Create", p) =>
+      switch (of_pair(p)) {
+      | Some((k, v)) => Attr.create(k, v)
+      | None => attr_err(d)
+      }
+    | ("Style", {term: ListLit(styles), _}) => render_styles(styles)
+    | ("OnClick", handler) => Attr.on_click(on_(mvu, handler))
+    | ("OnMousedown", handler) => Attr.on_mousedown(on_(mvu, handler))
+    | ("OnInput", handler) => Attr.on_input(on_input(mvu, handler))
+    | _ => attr_err(d)
+    }
+  | None => attr_err(d)
+  };
+};
+
+let of_error = (elide_errors: bool, mvu: t, d: DHExp.t): Node.t => {
+  let d = !elide_errors ? d : Exp.empty_hole();
+  mvu.view_term(d);
+};
+
+let rec render_elem = (~elide_errors=false, mvu: t, d: DHExp.t): Node.t =>
+  switch (of_constructor(d)) {
+  | Some(x) =>
+    switch (x) {
+    | ("Text", {term: Atom(String(str)), _}) => Node.text(str)
+    | ("Bool", {term: Atom(Bool(b)), _}) => Node.text(string_of_bool(b))
+    | ("Int", {term: Atom(Int(n)), _}) =>
+      switch (Bigint.to_int(n)) {
+      | Some(n) => Node.text(string_of_int(n))
+      | None => of_error(elide_errors, mvu, d)
+      }
+    | ("Float", {term: Atom(Float(f)), _}) =>
+      Node.text(string_of_float(f))
+    | ("Div", body) =>
+      let (attrs, divs) = attrs_and_elems(mvu, body);
+      Node.div(~attrs, divs);
+    | ("Span", body) =>
+      let (attrs, divs) = attrs_and_elems(mvu, body);
+      Node.span(~attrs, divs);
+    | (constructor_name, body) =>
+      switch (List.assoc_opt(constructor_name, input_type_mappings)) {
+      | Some(input_type) => input_of(input_type, mvu, body)
+      | None => of_error(elide_errors, mvu, d)
+      }
+    }
+  | _ => of_error(elide_errors, mvu, d)
+  }
+and input_of = (input_type: string, mvu: t, body: DHExp.t) => {
+  let (attrs, _divs) = attrs_and_elems(mvu, body);
+  Node.input(~attrs=[Attr.create("type", input_type)] @ attrs, ());
+}
+and attrs_and_elems = (mvu: t, body: DHExp.t): (list(Attr.t), list(Node.t)) =>
+  switch (DHExp.strip_ascriptions(body).term) {
+  | Tuple([{term: ListLit(attrs), _}, {term: ListLit(divs), _}]) => (
+      List.map(render_attr(mvu), attrs),
+      List.map(render_elem(mvu), divs),
+    )
+  | _ => ([], [mvu.view_term(body)])
+  };
+
+let go = (mvu: t): Node.t => {
+  let attrs = [Attr.tabindex(2), Attr.classes(["MVU-render"])];
+  Node.div(~attrs, [render_elem(mvu, mvu.model)]);
+};

src/haz3lcore/projectors/ProjectorInit.re

@@ -15,6 +15,7 @@ let to_module = (kind: ProjectorCore.Kind.t): (module Cooked) =>
   | TextArea => (module Cook(TextAreaProj.M))
   | Livelit => (module Cook(LivelitProj.M))
   | Card => (module Cook(CardProj.M))
+  | HTML => (module Cook(HTMLProj.M))
   | Csv => (module Cook(CSVProjector.M))
   };
 

src/haz3lcore/projectors/implementations/HTMLProj.re

@@ -0,0 +1,42 @@
+open Util;
+open ProjectorBase;
+
+module M: Projector = {
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type model = Language.Grammar.exp_t(Language.IdTagged.IdTag.t);
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type action = unit;
+
+  let init = (any: Language.Any.t) =>
+    switch (any) {
+    //TODO: Be more (and less) picky
+    | Exp({term: Ap(_, {term: Constructor("Div", _), _}, _), _} as exp) =>
+      Some(exp)
+    | _ => None
+    };
+
+  let focusable = Focusable.non;
+  let dynamics = false;
+  let placeholder = (_, _) => ProjectorCore.Shape.inline(10);
+  let update = (m, _, _) => m;
+
+  let view = ({model, info, parent, view_seg, _}: View.args(model, action)) => {
+    let seed: HazelDOM.t = {
+      model:
+        switch (info.syntax |> info.utility.seg_to_term) {
+        | Some(Exp(term)) => term
+        | _ => model
+        },
+      inject: (new_model: model) =>
+        /* Allow HTMLements to replace themselves wholesale. Note that
+           this will fail if anything other than a builtin is used in
+           a handler */
+        parent(SetSyntax(Exp(new_model) |> info.utility.term_to_seg)),
+      view_term: term =>
+        Exp(term)
+        |> info.utility.term_to_seg
+        |> view_seg(~background=false, Exp),
+    };
+    View.mk(HazelDOM.go(seed));
+  };
+};

src/language/ProjectorKind.re

@@ -16,7 +16,8 @@ type t =
   | Card
   | Livelit
   | TextArea
-  | Csv;
+  | Csv
+  | HTML;
 
 let livelit_projectors: list(t) = [
   Csv, /* Competes with Card for empty list */
@@ -27,6 +28,7 @@ let livelit_projectors: list(t) = [
   TextArea,
   Card,
   Livelit,
+  HTML,
 ];
 
 /* Note: Probe intentionally excluded - probes use separate action path */
@@ -51,6 +53,7 @@ let name = (p: t): string =>
   | Livelit => "livelit"
   | TextArea => "text"
   | Csv => "csv"
+  | HTML => "html"
   };
 
 /* This must be updated and kept 1-to-1 with the above
@@ -68,6 +71,7 @@ let of_name = (p: string): t =>
   | "livelit" => Livelit
   | "card" => Card
   | "csv" => Csv
+  | "html" => HTML
   | _ => failwith("Unknown projector kind")
   };
 

src/language/builtins/BuiltinsADT.re

@@ -172,11 +172,43 @@ module Option = {
   ];
 };
 
+module HTML = {
+  let t: Typ.t =
+    IdTagged.FreshGrammar.Typ.rec_(
+      IdTagged.FreshGrammar.TPat.var("HTML"),
+      sum_type([
+        ("Text", Some(string())),
+        ("Bool", Some(bool())),
+        ("Int", Some(int())),
+        ("Float", Some(float())),
+        ("Div", Some(prod([list(var("Attr")), list(var("HTML"))]))),
+        ("Span", Some(prod([list(var("Attr")), list(var("HTML"))]))),
+        ("Button", Some(list(var("Attr")))),
+        ("Checkbox", Some(list(var("Attr")))),
+        ("Radio", Some(list(var("Attr")))),
+        ("Range", Some(list(var("Attr")))),
+      ]),
+    );
+  let attr =
+    sum_type([
+      ("Create", Some(prod([string(), string()]))),
+      ("Style", Some(list(prod([string(), string()])))),
+      ("OnClick", Some(arrow(var("HTML"), var("HTML")))),
+      ("OnMousedown", Some(arrow(var("HTML"), var("HTML")))),
+      (
+        "OnInput",
+        Some(arrow(prod([var("HTML"), string()]), var("HTML"))),
+      ),
+    ]);
+};
+
 // List of type aliases to add to the context
 let type_aliases: list((string, Typ.t)) = [
   ("Ord", Ord.t),
   ("Option", Option.t),
   ("Either", Either.t),
+  ("HTML", HTML.t),
+  ("Attr", HTML.attr),
   ("$Meta", meta_type),
 ];
 
@@ -198,7 +230,8 @@ let constructors: Ctx.t = {
       let cons_map =
         switch (Typ.term_of(typ)) {
         | Sum(cons_map) => cons_map
-        | _ => failwith("Type alias must be a sum type")
+        | Rec(_, {term: Sum(cons_map), _}) => cons_map
+        | _ => failwith("Type alias must be a sum or recursive sum type")
         };
       Ctx.add_ctrs(ctx, name, Id.invalid, cons_map);
     },

src/language/term/Typ.re

@@ -1128,6 +1128,22 @@ and paren_pretty_print = typ =>
     pretty_print(typ);
   };
 
+/* Replaces rec types with a variable with the same name as
+ * their rec parameter. Intended mostly for printing */
+let abstract_rec_types =
+  map_term(
+    ~f_typ=
+      (continue, t) =>
+        switch (t.term) {
+        | Rec({term: Var(name), _}, _) => {
+            ...t,
+            term: Var(name),
+          }
+        | _ => continue(t)
+        },
+    _,
+  );
+
 /**
  * Converts a list of types (`tys`) into a product type.
  *

src/web/app/editors/code/ContextMenu.re

@@ -419,6 +419,7 @@ module Projectors = {
     | TextArea => "Text"
     | Csv => "CSV"
     | Livelit => "Livelit"
+    | HTML => "HTML"
     | Probe => "Probe" /* shouldn't appear in menu */
     };
 

src/web/app/inspector/CursorInspector.re

@@ -94,6 +94,7 @@ let view_any = (~globals, any: Any.t) =>
 
 let view_type = (~globals, typ: Typ.t) =>
   typ
+  |> Typ.abstract_rec_types
   |> CodeViewable.view_typ(~globals, ~settings=code_view_settings)
   |> code_box_container;