Prepare to output non-single-expr messages.

3 files changed, 47 insertions, 38 deletions

diff --git a/discocaml/ast.ml b/discocaml/ast.ml
index 009ea87..22f3790 100644
--- a/discocaml/ast.ml
+++ b/discocaml/ast.ml
@@ -1,3 +1,15 @@
 type expr = Foo [@@deriving show { with_path = false }]
 
 let expr_of_parsetree : Parsetree.expression -> expr = function _ -> Foo
+
+let parsetree_of_expr : expr -> Parsetree.expression =
+  let expression (pexp_desc : Parsetree.expression_desc) : Parsetree.expression
+      =
+    {
+      pexp_desc;
+      pexp_loc = Location.none;
+      pexp_loc_stack = [];
+      pexp_attributes = [];
+    }
+  in
+  function Foo -> expression (Pexp_constant (Pconst_char '!'))
diff --git a/discocaml/discocaml.ml b/discocaml/discocaml.ml
index cd99c9a..2140fa5 100644
--- a/discocaml/discocaml.ml
+++ b/discocaml/discocaml.ml
@@ -1,13 +1,19 @@
-type command = [ `Roundtrip ]
+type command = [ `Parse | `DrawTree | `RunCBN | `RunCBV | `StepCBN | `StepCBV ]
 
 let command_of_yojson = function
-  | `String "Roundtrip" -> Ok `Roundtrip
+  | `String "Parse" -> Ok `Parse
+  | `String "DrawTree" -> Ok `DrawTree
+  | `String "RunCBN" -> Ok `RunCBN
+  | `String "RunCBV" -> Ok `RunCBV
+  | `String "StepCBN" -> Ok `StepCBN
+  | `String "StepCBV" -> Ok `StepCBV
   | _ -> Error "invalid command"
 
 type request = { expr : string; command : command }
 [@@deriving of_yojson { exn = true }]
 
-type response_expr = { expr : string } [@@deriving to_yojson { exn = true }]
+type response_expr = { expr : string; has_redex : bool }
+[@@deriving to_yojson { exn = true }]
 
 type response = [ `Error of string | `Expr of response_expr ]
 [@@deriving to_yojson { exn = true }]
@@ -17,47 +23,37 @@ let%expect_test _ =
   [%expect {| ["Error","foo"] |}]
 
 let%expect_test _ =
-  Yojson.Safe.to_channel stdout (response_to_yojson (`Expr { expr = "foo" }));
-  [%expect {| ["Expr",{"expr":"foo"}] |}]
-(*
-type position = [%import: Lexing.position] [@@deriving show]
-
-type location = [%import: (Location.t[@with Lexing.position := position])]
-[@@deriving show]
-
-type constant = [%import: Parsetree.constant] [@@deriving show]
-type expression_desc = [%import: Parsetree.expression_desc] [@@deriving show]
-type expression = [%import: Parsetree.expression] [@@deriving show]
-
-type structure_item_desc = [%import: Parsetree.structure_item_desc]
-[@@deriving show]
-
-type structure_item = [%import: Parsetree.structure_item] [@@deriving show]
-type structure = [%import: Parsetree.structure] [@@deriving show]
-type toplevel_phrase = [%import: Parsetree.toplevel_phrase] [@@deriving show]
-
-let parse ~path (src : string) =
-  let buf = Lexing.from_string src in
-  buf.lex_start_p <- { buf.lex_start_p with pos_fname = path };
-  buf.lex_curr_p <- { buf.lex_curr_p with pos_fname = path };
-  Parse.expression buf
-
-let () =
-  parse ~path:"main.ml" " print_endline ((\"Hello, world!\") )"
-  |> Format.fprintf Format.std_formatter "\n%a\n" Pprintast.expression
-*)
+  Yojson.Safe.to_channel stdout
+    (response_to_yojson (`Expr { expr = "foo"; has_redex = false }));
+  [%expect {| ["Expr",{"expr":"foo","has_redex":false}] |}]
 
 let handle_request { expr; command } : response =
   try
     let buf = Lexing.from_string expr in
     let expr = Parse.expression buf in
+    let expr = Ast.expr_of_parsetree expr in
+
+    let expr_response (expr : Ast.expr) : response =
+      let buf = Buffer.create 16 in
+      (let fmt = Format.formatter_of_buffer buf in
+       Pprintast.expression fmt (Ast.parsetree_of_expr expr);
+       Format.pp_print_flush fmt ());
+      let has_redex = Option.is_some (Eval.find_redex_cbn expr) in
+      `Expr { expr = Buffer.contents buf; has_redex }
+    in
+
+    let step_with (find_redex : Ast.expr -> Eval.path option) (expr : Ast.expr)
+        : Ast.expr =
+      match find_redex expr with
+      | Some path -> Eval.reduce expr path
+      | None -> failwith "no redex"
+    in
+
     match command with
-    | `Roundtrip ->
-        let buf = Buffer.create 16 in
-        (let fmt = Format.formatter_of_buffer buf in
-         Pprintast.expression fmt expr;
-         Format.pp_print_flush fmt ());
-        `Expr { expr = Buffer.contents buf }
+    | `Parse -> expr_response expr
+    | `StepCBN -> expr_response (step_with Eval.find_redex_cbn expr)
+    | `StepCBV -> expr_response (step_with Eval.find_redex_cbv expr)
+    | `DrawTree | `RunCBN | `RunCBV -> failwith "not implemented"
   with
   | Failure msg -> `Error msg
   | exn -> `Error ("uncaught exception: " ^ Printexc.to_string exn)
diff --git a/discocaml/eval.ml b/discocaml/eval.ml
index 68bb637..63dd6f7 100644
--- a/discocaml/eval.ml
+++ b/discocaml/eval.ml
@@ -5,3 +5,4 @@ type path = int list
 
 let find_redex_cbv : expr -> path option = function _ -> None
 let find_redex_cbn : expr -> path option = function _ -> None
+let reduce : expr -> path -> expr = fun e _ -> e