Table projector

src/CLI/Print.re

@@ -6,6 +6,7 @@ let exp_to_segment_settings: ExpToSegment.Settings.t = {
   label_format: QuoteWhenNecessary,
   inline: false,
   fold_case_clauses: false,
+  project_tables: false,
   fold_fn_bodies: `NoFold,
   hide_fixpoints: false,
   show_filters: true,

src/haz3lcore/pretty/ExpToSegment.re

@@ -40,6 +40,7 @@ module Settings = {
       | `Text
       | `NoFold
     ],
+    project_tables: bool,
     hide_fixpoints: bool,
     show_filters: bool,
     show_unknown_as_hole: bool,
@@ -51,6 +52,7 @@ module Settings = {
     label_format: QuoteWhenNecessary,
     inline,
     fold_case_clauses: !settings.evaluation.show_case_clauses,
+    project_tables: settings.evaluation.project_tables,
     fold_fn_bodies:
       fold_fn_bodies
       |> Option.value(
@@ -68,6 +70,7 @@ module Settings = {
       label_format: QuoteWhenNecessary,
       inline,
       fold_case_clauses: false,
+      project_tables: false,
       fold_fn_bodies: `NoFold,
       hide_fixpoints: false,
       show_filters: true,
@@ -470,8 +473,8 @@ let rec parenthesize =
   | Ap(Reverse, e1, e2) =>
     Ap(
       Reverse,
-      parenthesize(e1) |> paren_assoc_at(Precedence.eqs),
-      parenthesize(e2) |> paren_at(Precedence.eqs),
+      parenthesize(e1) |> paren_at(Precedence.eqs), // Associativity is backwards because e2 goes before e1
+      parenthesize(e2) |> paren_assoc_at(Precedence.eqs),
     )
     |> rewrap
   | TypAp(e, tp) =>
@@ -1056,6 +1059,15 @@ let fold_fun_if = (condition, f_name: string, pieces, exp) =>
   | `NoFold => pieces
   };
 
+let project_table_if = (should_project, pieces) =>
+  if (should_project) {
+    switch (MakeTerm.for_projection([pieces])) {
+    | None => failwith("ExpToSegment.fold_if")
+    | Some(any) => [ProjectorInit.init_or_noop(Table, pieces, any)]
+    };
+  } else {
+    [pieces];
+  };
 /* We assume that parentheses have already been added as necessary, and
       that the expression has no Closures or DynamicErrorHoles
    */
@@ -1157,7 +1169,10 @@ let rec exp_to_pretty = (~settings: Settings.t, exp: Exp.t): pretty => {
             ),
         ],
       );
-    wrap(exp, p_just([form(x, xs)]));
+    wrap(
+      exp,
+      p_just(form(x, xs) |> project_table_if(settings.project_tables)),
+    );
   // TODO: Add optional newlines
   | Var(v) => wrap(exp, text_to_pretty(exp |> Exp.rep_id, Sort.Exp, v))
   | BinOp(op, l, r) =>
@@ -1433,13 +1448,17 @@ let rec exp_to_pretty = (~settings: Settings.t, exp: Exp.t): pretty => {
     and+ e2 = go(e2);
     wrap(exp, e1 @ [mk_form(ApExp, id, [e2])]);
   | Ap(Reverse, e1, e2) =>
+    print_endline("Printing reverse application");
+    print_endline(Exp.show(exp));
     // TODO: Add optional newlines
     let id = exp |> Exp.rep_id;
     let+ e1 = go(e1)
     and+ e2 = go(e2);
+
     wrap(
       exp,
       e2
+      @ (settings.inline ? [] : [Secondary(mk_newline(Id.mk()))])
       @ [
         Tile({
           id,

src/haz3lcore/projectors/ProjectorInfo.re

@@ -12,6 +12,7 @@ let utility: ProjectorBase.utility = {
       ~settings={
         ...ExpToSegment.Settings.of_core(~inline=true, CoreSettings.off),
         show_unknown_as_hole: false,
+        fold_fn_bodies: `NoFold,
       },
     );
   let lift_syntax =

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))
+  | Table => (module Cook(TableProj.M))
   | Csv => (module Cook(CSVProjector.M))
   };
 

src/haz3lcore/projectors/implementations/TableProj.re

@@ -0,0 +1,228 @@
+open Util;
+open Virtual_dom.Vdom;
+open ProjectorBase;
+open Language;
+
+let max_column_length = 12;
+
+let table_of =
+    (any: Any.t): option((list(LabeledTuple.label), list(list(Exp.t)))) =>
+  switch (any) {
+  | Exp({term: ListLit(es), _}) =>
+    let data: list(option((list(string), list(TermBase.exp_t)))) =
+      List.map(
+        e => {
+          switch (Unboxing.unbox(LabeledTupleEntries, e)) {
+          // TODO Stop doing this with unboxing and deconstruct it here with the parens
+          | IndetMatch => None
+          | DoesNotMatch => None
+          | Matches(entries: list((option(string), TermBase.exp_t))) =>
+            let f: option(list((string, TermBase.exp_t))) =
+              OptUtil.sequence(
+                List.map(
+                  ((label, value)) =>
+                    switch (label) {
+                    | Some(l) => Some((l, value))
+                    | None => None
+                    },
+                  entries,
+                ),
+              );
+
+            let g: option((list(string), list(TermBase.exp_t))) =
+              f |> Option.map(List.split);
+
+            g;
+          }
+        },
+        es,
+      );
+
+    let data: option(list((list(string), list(TermBase.exp_t)))) =
+      OptUtil.sequence(data);
+    switch (data) {
+    | Some(data: list((list(string), list(TermBase.exp_t)))) =>
+      let (headers: list(list(string)), rows: list(list(TermBase.exp_t))) =
+        List.split(data);
+
+      // If all the headers aren't the same return None
+      switch (headers) {
+      | [] => None
+      | [h, ..._] when List.for_all(x => x == h, headers) =>
+        let headers = h;
+        Some((headers, rows));
+
+      | _ => None
+      };
+    | None => None
+    };
+  | _ => None
+  };
+
+let get = (info: info): (list(LabeledTuple.label), list(list(Exp.t))) =>
+  switch (info.syntax |> info.utility.seg_to_term) {
+  | Some(s) =>
+    switch (table_of(s)) {
+    | Some(s) => s
+    | None => failwith("TextArea: get: Not a table")
+    }
+  | None => failwith("TextArea: get: Not a table")
+  };
+
+let key_handler = (id, ~parent, evt) => {
+  open Effect;
+  let key = Key.mk(KeyDown, evt);
+
+  switch (key.key) {
+  | D("ArrowRight" | "ArrowDown")
+      when WebUtil.TextArea.is_last_pos(Id.cls(id)) =>
+    JsUtil.get_elem_by_id(Id.cls(id))##blur;
+    Many([parent(Escape(Right)), Stop_propagation]);
+  | D("ArrowLeft" | "ArrowUp")
+      when WebUtil.TextArea.is_first_pos(Id.cls(id)) =>
+    JsUtil.get_elem_by_id(Id.cls(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 len_seg = (utility: utility, seg: Segment.t): int =>
+  seg |> utility.seg_to_string |> String.length;
+
+let seg_of_exp = (utility: utility, exp: Exp.t): (Segment.t, int) => {
+  let seg = utility.term_to_seg(Exp(exp));
+  (seg, len_seg(utility, seg));
+};
+
+let abbreviated_seg_of =
+    (utility: utility, available: int, exp: Exp.t): (Segment.t, int) => {
+  let (abbr_exp, _length) =
+    exp |> DHExp.strip_ascriptions |> Abbreviate.abbreviate_exp(~available);
+  seg_of_exp(utility, abbr_exp);
+};
+let length_cls = (length: int): string =>
+  if (length > 10) {
+    "extra";
+  } else if (length > 9) {
+    "s6";
+  } else if (length > 8) {
+    "s5";
+  } else if (length > 7) {
+    "s4";
+  } else if (length > 6) {
+    "s3";
+  } else if (length > 5) {
+    "s2";
+  } else if (length > 4) {
+    "s1";
+  } else {
+    "s0";
+  };
+let value_view = (_info: info, utility: utility, view_seg, exp) => {
+  let (seg, length) = abbreviated_seg_of(utility, max_column_length, exp);
+
+  Node.div(
+    ~attrs=[
+      //Attr.title(DynCursor.Debug.str(info, closure)),
+      Attr.classes([
+        "value",
+        length_cls(length),
+        // @ DynCursor.clss(info, closure)
+        // @ (Option.is_some(cur_ap(info)) ? ["ap"] : [])
+        // @ (!is_value(closure.value) ? ["indet"] : []),
+      ]),
+      // Attr.on_double_click(_ => local(ToggleShowAllVals(index))),
+      // Attr.on_pointerdown(val_pointerdown),
+      // Attr.on_pointerup(val_pointerup),
+      // Attr.on_mousemove(val_mousemove),
+    ],
+    [view_seg(Sort.Exp, seg)],
+  );
+};
+
+let table =
+    (
+      info,
+      ~parent as _: external_action => Ui_effect.t(unit),
+      (headers, rows): (list(LabeledTuple.label), list(list(Exp.t))),
+      ~view_seg: (Sort.t, Segment.t) => Node.t,
+    ) =>
+  Node.table(
+    ~attrs=[Attr.classes(["table"])],
+    [
+      Node.thead([
+        Node.tr(List.map(h => Node.th([Node.text(h)]), headers)),
+      ]),
+      Node.tbody(
+        List.map(
+          row =>
+            Node.tr(
+              List.map(
+                e => Node.td([value_view(info, info.utility, view_seg, e)]),
+                row,
+              ),
+            ),
+          rows,
+        ),
+      ),
+    ],
+  );
+
+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 = (any: Any.t) =>
+    switch (table_of(any)) {
+    | Some(_) => Some()
+    | None => None
+    };
+
+  let focusable =
+    Focusable.{
+      pointer: None,
+      keyboard: None,
+    };
+  let dynamics = false;
+  let placeholder = (_, info) => {
+    let (header, rows): (list(string), list(list(TermBase.exp_t))) =
+      info |> get;
+    let max_header_length =
+      header |> List.map(String.length) |> List.fold_left((+), 0);
+    let max_row_length =
+      rows
+      |> List.map(row =>
+           row
+           |> List.map(e =>
+                Abbreviate.abbreviate_exp(~available=max_column_length, e)
+                |> snd
+              )
+           |> List.fold_left((+), 0, _)
+         )
+      |> List.fold_left(max, 0, _);
+    let max_length = max(max_header_length, max_row_length);
+
+    let num_rows = List.length(rows);
+    let num_cols = List.length(header);
+    ProjectorCore.Shape.{
+      vertical: Block(min(num_rows + 1, 10)), // +1 for header row
+      /* +2 for left and right padding */
+      horizontal: 4 + max_length * 1 + num_cols * 2 // +2 for left and right padding
+    };
+  };
+  let update = (model, _, _) => model;
+
+  let view = ({info, parent, view_seg, _}: View.args(model, action)): View.t =>
+    View.mk(table(info, ~view_seg, ~parent, info |> get));
+};

src/haz3lcore/zipper/action/Introduce.re

@@ -245,6 +245,7 @@ module Make =
           label_format: QuoteWhenNecessary,
           inline: true,
           fold_case_clauses: false,
+          project_tables: false,
           fold_fn_bodies: `NoFold,
           hide_fixpoints: false,
           show_filters: true,

src/language/CoreSettings.re

@@ -10,6 +10,7 @@ module Evaluation = {
     show_case_steps: bool,
     show_lookup_steps: bool,
     show_stepper_filters: bool,
+    project_tables: bool,
     // TODO[Matt]: Move this to somewhere where it is a per-scratch setting
     stepper_history: bool,
     show_settings: bool,
@@ -25,6 +26,7 @@ module Evaluation = {
     show_case_steps: false,
     show_lookup_steps: false,
     show_stepper_filters: false,
+    project_tables: false,
     stepper_history: false,
     show_settings: false,
     show_hidden_steps: false,

src/language/ProjectorKind.re

@@ -16,6 +16,7 @@ type t =
   | Card
   | Livelit
   | TextArea
+  | Table
   | Csv;
 
 let livelit_projectors: list(t) = [
@@ -27,6 +28,7 @@ let livelit_projectors: list(t) = [
   TextArea,
   Card,
   Livelit,
+  Table,
 ];
 
 /* Note: Probe intentionally excluded - probes use separate action path */
@@ -51,6 +53,7 @@ let name = (p: t): string =>
   | Livelit => "livelit"
   | TextArea => "text"
   | Csv => "csv"
+  | Table => "table"
   };
 
 /* 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
+  | "table" => Table
   | _ => failwith("Unknown projector kind")
   };