Query-based Accessibility

src/haz3lweb/Init.ml

@@ -30,6 +30,7 @@ let startup : PersistentData.t =
         mode = Documentation;
         explainThis =
           { show = true; show_feedback = false; highlight = NoHighlight };
+        accessibility = { enable = true; is_editing = false };
       };
     scratch =
       ( 0,

src/haz3lweb/Keyboard.re

@@ -42,6 +42,7 @@ let handle_key_event = (k: Key.t): option(Update.t) => {
     | (Down, "ArrowDown") => now(Select(Resize(Local(Down))))
     | (Down, "Home") => now(Select(Resize(Extreme(Left(ByToken)))))
     | (Down, "End") => now(Select(Resize(Extreme(Right(ByToken)))))
+    | (Up, "\\") => Some(Set(Accessibility(ToggleIsEditing)))
     | (_, "Enter") => now(Insert(Form.linebreak))
     | _ when String.length(key) == 1 =>
       /* Note: length==1 prevent specials like

src/haz3lweb/Model.re

@@ -38,6 +38,7 @@ type t = {
   results: ModelResults.t,
   statics: CachedStatics.t,
   explainThisModel: ExplainThisModel.t,
+  accessibilityModel: AccessibilityModel.t,
   ui_state,
 };
 
@@ -49,6 +50,7 @@ let mk = (editors, results, statics) => {
   results,
   statics,
   explainThisModel: ExplainThisModel.init,
+  accessibilityModel: AccessibilityModel.init,
   ui_state: ui_state_init,
 };
 
@@ -93,9 +95,18 @@ let load = (init_model: t): t => {
       ~mode=settings.mode,
       ~instructor_mode=settings.instructor_mode,
     );
+  let accessibilityModel = init_model.accessibilityModel;
   let ui_state = init_model.ui_state;
   let statics = Editors.mk_statics(~settings, editors);
-  {editors, settings, results, statics, explainThisModel, ui_state};
+  {
+    editors,
+    settings,
+    results,
+    statics,
+    explainThisModel,
+    accessibilityModel,
+    ui_state,
+  };
 };
 
 let save = ({editors, settings, explainThisModel, results, _}: t) => {

src/haz3lweb/Settings.re

@@ -24,6 +24,7 @@ type t = {
   instructor_mode: bool,
   benchmark: bool,
   explainThis: ExplainThisModel.Settings.t,
+  accessibility: AccessibilityModel.Settings.t,
   mode,
 };
 

src/haz3lweb/Update.re

@@ -181,6 +181,20 @@ let update_settings =
         mode,
       },
     }
+  | Accessibility(ToggleEnable) =>
+    let accessibility = {
+      ...settings.accessibility,
+      enable: !settings.accessibility.enable,
+    };
+    let settings = {...settings, accessibility};
+    {...model, settings};
+  | Accessibility(ToggleIsEditing) =>
+    let accessibility = {
+      ...settings.accessibility,
+      is_editing: !settings.accessibility.is_editing,
+    };
+    let settings = {...settings, accessibility};
+    {...model, settings};
   };
 
 let schedule_evaluation = (~schedule_action, model: Model.t): unit =>
@@ -392,6 +406,19 @@ let rec apply =
           : Zipper.can_put_down(z)
               ? PerformAction(Put_down) : MoveToNextHole(Right);
       apply(model, a, state, ~schedule_action);
+    | PerformAction(a) when model.settings.accessibility.is_editing =>
+      let accessibilityModel =
+        AccessibilityUpdate.update_model(
+          ~settings=model.settings,
+          ~ctx_init=
+            model.editors |> Editors.get_ctx_init(~settings=model.settings),
+          ~editor=model.editors |> Editors.get_editor,
+          model.accessibilityModel,
+          Edit(a),
+        );
+      let model = {...model, accessibilityModel};
+      JsUtil.log(model.accessibilityModel.input);
+      Ok(model);
     | PerformAction(a)
         when model.settings.core.assist && model.settings.core.statics =>
       let model = UpdateAssistant.reset_buffer(model);

src/haz3lweb/UpdateAction.re

@@ -27,6 +27,7 @@ type settings_action =
   | InstructorMode
   | Evaluation(evaluation_settings_action)
   | ExplainThis(ExplainThisModel.Settings.action)
+  | Accessibility(AccessibilityModel.Settings.action)
   | Mode(Settings.mode);
 
 [@deriving (show({with_path: false}), sexp, yojson)]
@@ -126,7 +127,8 @@ let is_edit: t => bool =
     | Benchmark
     | ContextInspector
     | InstructorMode
-    | Evaluation(_) => false
+    | Evaluation(_)
+    | Accessibility(_) => false
     }
   | SetMeta(meta_action) =>
     switch (meta_action) {
@@ -186,7 +188,8 @@ let reevaluate_post_update: t => bool =
     | Elaborate
     | Dynamics
     | InstructorMode
-    | Mode(_) => true
+    | Mode(_)
+    | Accessibility(_) => true
     }
   | SetMeta(meta_action) =>
     switch (meta_action) {
@@ -238,7 +241,8 @@ let should_scroll_to_caret =
     | Benchmark
     | ContextInspector
     | InstructorMode
-    | Evaluation(_) => false
+    | Evaluation(_)
+    | Accessibility(_) => false
     }
   | SetMeta(meta_action) =>
     switch (meta_action) {

src/haz3lweb/view/Page.re

@@ -2,6 +2,7 @@ open Js_of_ocaml;
 open Haz3lcore;
 open Virtual_dom.Vdom;
 open Node;
+open Util;
 
 let handlers = (~inject: UpdateAction.t => Ui_effect.t(unit), model) => {
   let get_selection = (model: Model.t): string =>
@@ -51,7 +52,16 @@ let handlers = (~inject: UpdateAction.t => Ui_effect.t(unit), model) => {
 let main_view =
     (
       ~inject: UpdateAction.t => Ui_effect.t(unit),
-      {settings, editors, explainThisModel, results, statics, ui_state, _}: Model.t,
+      {
+        settings,
+        editors,
+        explainThisModel,
+        accessibilityModel,
+        results,
+        statics,
+        ui_state,
+        _,
+      }: Model.t,
     ) => {
   let editor = Editors.get_editor(editors);
   let statics = Editors.lookup_statics(~settings, ~statics, editors);
@@ -64,6 +74,7 @@ let main_view =
       @ [EditorModeView.view(~inject, ~settings, ~editors)],
     );
   let bottom_bar = CursorInspector.view(~inject, ~settings, cursor_info);
+  let a11y_bar = Accessibility.view(~_inject=inject, accessibilityModel);
   let sidebar =
     settings.explainThis.show && settings.core.statics
       ? ExplainThis.view(
@@ -76,6 +87,14 @@ let main_view =
       : div([]);
   let highlights =
     ExplainThis.get_color_map(~settings, ~explainThisModel, cursor_info);
+  let highlights =
+    Some(
+      accessibilityModel.colorings
+      |> List.fold_left(
+           (map, (id, color)) => Id.Map.add(id, color, map),
+           highlights |> OptUtil.get(() => Id.Map.empty),
+         ),
+    );
   let editors_view =
     switch (editors) {
     | Scratch(idx, _) =>
@@ -129,6 +148,7 @@ let main_view =
     ),
     sidebar,
     bottom_bar,
+    a11y_bar,
   ];
 };
 

src/haz3lweb/view/a11y/Accessibility.re

@@ -0,0 +1,26 @@
+open Virtual_dom.Vdom;
+//open Util.Web;
+
+let inputField_id = "a11y-input";
+let outputArea_id = "a11y-output";
+
+let input_view = (id, input): Node.t => {
+  Node.div(~attr=Attr.id(id), [Node.text("\\" ++ input)]);
+};
+
+let output_view = (id, content): Node.t => {
+  Node.div(~attr=Attr.id(id), [Node.text(content)]);
+};
+
+let view = (~_inject, model: AccessibilityModel.t): Node.t => {
+  Node.div(
+    ~attr=Attr.classes(["a11y"]),
+    [
+      input_view(inputField_id, model.input),
+      output_view(
+        outputArea_id,
+        model.query_result |> Option.value(~default=""),
+      ),
+    ],
+  );
+};

src/haz3lweb/view/a11y/AccessibilityEngine.re

@@ -0,0 +1,121 @@
+open Haz3lcore;
+open Sexplib.Std;
+open QueryAst;
+
+let query_parser = (query: string) => {
+  let lexbuf = Lexing.from_string(query);
+  let result =
+    switch (Parser.main(Lexer.token, lexbuf)) {
+    | query_ast => Some(query_ast)
+    | exception _ => None
+    };
+  JsUtil.log(result);
+  result;
+};
+
+module QueryResult = {
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type textobject =
+    | Term(Term.t)
+    | Info(Info.t)
+    | Type(Typ.t);
+
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type t = {
+    msg: string,
+    t_object: option(textobject),
+  };
+
+  let empty = {msg: "nothing", t_object: None};
+  let error = (msg: string) => {msg, t_object: None};
+
+  let mk = (msg, t_object): t => {
+    {msg, t_object};
+  };
+
+  let change_msg = (msg: string, result: t): t => {
+    {msg, t_object: result.t_object};
+  };
+
+  let get_id = (result: t): option(Id.t) => {
+    switch (result.t_object) {
+    | Some(Info(ci)) => Some(Info.id_of(ci))
+    | _ => None
+    };
+  };
+};
+
+let rec evaluate_text_object =
+        (
+          ~settings: Settings.t,
+          ~ctx_init,
+          ~editor: Editor.t,
+          text_obj: text_object,
+        ) => {
+  switch (text_obj) {
+  | Inner(Term) =>
+    let zipper = editor.state.zipper;
+    let (term, _) = MakeTerm.from_zip_for_sem(zipper);
+    let info_map =
+      Interface.Statics.mk_map_ctx(settings.core, ctx_init, term);
+    let result =
+      switch (zipper.backpack, Indicated.index(zipper)) {
+      | _ when !settings.core.statics => QueryResult.empty
+      | _ when Id.Map.is_empty(info_map) =>
+        QueryResult.error("No Static information available")
+      | (_, None) => QueryResult.error("No cursor in program")
+      | (_, Some(id)) =>
+        switch (Id.Map.find_opt(id, info_map)) {
+        | None => QueryResult.error("Whitespace or Comment")
+        | Some(ci) => QueryResult.mk("info", Some(QueryResult.Info(ci)))
+        }
+      };
+    result;
+  | Inner(Parenthesis) => QueryResult.empty
+  | Queried(query) => evaluate_query(~settings, ~ctx_init, ~editor, query)
+  };
+}
+
+and evaluate_query =
+    (
+      ~settings: Settings.t,
+      ~ctx_init,
+      ~editor: Editor.t,
+      query: QueryAst.query,
+    )
+    : QueryResult.t => {
+  let (text_obj_command, q_op) = query;
+  let text_obj_result =
+    evaluate_text_object(~settings, ~ctx_init, ~editor, text_obj_command);
+  switch (text_obj_result.t_object, q_op) {
+  | (Some(Info(ci)), (None, Type)) =>
+    switch (ci) {
+    | InfoExp(e) =>
+      QueryResult.mk(e.ty |> Typ.show, Some(QueryResult.Type(e.ty)))
+    | InfoPat(p) =>
+      QueryResult.mk(p.ty |> Typ.show, Some(QueryResult.Type(p.ty)))
+    | InfoTyp(t) =>
+      QueryResult.mk(t.ty |> Typ.show, Some(QueryResult.Type(t.ty)))
+    | _ => QueryResult.error("No type information available")
+    }
+  | (_, (None, Type)) => QueryResult.error("No type information available")
+  | _ => QueryResult.error("No information available")
+  };
+};
+
+let evaluate_command =
+    (
+      ~settings: Settings.t,
+      ~ctx_init,
+      ~editor: Editor.t,
+      command: QueryAst.command,
+    )
+    : QueryResult.t => {
+  switch (command) {
+  | Query(query) => evaluate_query(~settings, ~ctx_init, ~editor, query)
+  | Partial(text_object) =>
+    evaluate_text_object(~settings, ~ctx_init, ~editor, text_object)
+    |> QueryResult.change_msg("The selected text is highlighted")
+  | Action(_) => QueryResult.empty
+  };
+};

src/haz3lweb/view/a11y/AccessibilityModel.re

@@ -0,0 +1,24 @@
+open Sexplib.Std;
+module Sexp = Sexplib.Sexp;
+open Haz3lcore;
+module Settings = {
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type t = {
+    enable: bool,
+    is_editing: bool,
+  };
+
+  [@deriving (show({with_path: false}), sexp, yojson)]
+  type action =
+    | ToggleEnable
+    | ToggleIsEditing;
+};
+
+[@deriving (show({with_path: false}), sexp, yojson)]
+type t = {
+  input: string,
+  query_result: option(string),
+  colorings: list((Id.t, string)),
+};
+
+let init = {input: "", query_result: None, colorings: []};