From ed686f7c7fdce0c3062a2859e32e974c096246df Mon Sep 17 00:00:00 2001
From: Nathan Ringo <nathan@remexre.com>
Date: Fri, 19 Jan 2024 19:56:39 -0600
Subject: Add notes to eval output.

---
 discocaml/ast.ml       |  7 +++++++
 discocaml/discocaml.ml | 30 ++++++++++++++++++------------
 discocaml/eval.ml      | 13 ++++++++++++-
 3 files changed, 37 insertions(+), 13 deletions(-)

(limited to 'discocaml')

diff --git a/discocaml/ast.ml b/discocaml/ast.ml
index 63893fa..92ac32d 100644
--- a/discocaml/ast.ml
+++ b/discocaml/ast.ml
@@ -161,3 +161,10 @@ let parsetree_of_subexpr (ast : 'a ast) : expr -> Parsetree.expression =
 
 let parsetree_of_expr (ast : expr ast) : Parsetree.expression =
   parsetree_of_subexpr ast (get_subexpr ast ast.root)
+
+let show_expr (expr : expr ast) : string =
+  let buf = Buffer.create 16 in
+  let fmt = Format.formatter_of_buffer buf in
+  Pprintast.expression fmt (parsetree_of_expr expr);
+  Format.pp_print_flush fmt ();
+  Buffer.contents buf
diff --git a/discocaml/discocaml.ml b/discocaml/discocaml.ml
index df5cef3..e244e26 100644
--- a/discocaml/discocaml.ml
+++ b/discocaml/discocaml.ml
@@ -14,7 +14,7 @@ let command_of_yojson = function
 type request = { expr : string; command : command }
 [@@deriving of_yojson { exn = true }]
 
-type response_expr = { expr : string; has_redex : bool }
+type response_expr = { expr : string; has_redex : bool; note : string option }
 [@@deriving to_yojson { exn = true }]
 
 type response =
@@ -27,8 +27,9 @@ let%expect_test _ =
 
 let%expect_test _ =
   Yojson.Safe.to_channel stdout
-    (response_to_yojson (`Expr { expr = "foo"; has_redex = false }));
-  [%expect {| ["Expr",{"expr":"foo","has_redex":false}] |}]
+    (response_to_yojson
+       (`Expr { expr = "foo"; has_redex = false; note = None }));
+  [%expect {| ["Expr",{"expr":"foo","has_redex":false,"note":null}] |}]
 
 let handle_request { expr; command } : response =
   try
@@ -36,13 +37,13 @@ let handle_request { expr; command } : response =
     let expr = Parse.expression buf in
     let expr = expr_of_parsetree expr in
 
-    let expr_response (expr : expr ast) : response =
-      let buf = Buffer.create 16 in
-      (let fmt = Format.formatter_of_buffer buf in
-       Pprintast.expression fmt (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 }
+    let expr_response ?(note : string option) (expr : expr ast) : response =
+      `Expr
+        {
+          expr = show_expr expr;
+          has_redex = Option.is_some (Eval.find_redex_cbn expr);
+          note;
+        }
     in
 
     let step_with (find_redex : expr ast -> expr index option) (expr : expr ast)
@@ -54,10 +55,15 @@ let handle_request { expr; command } : response =
 
     match command with
     | `Parse -> expr_response expr
-    | `StepCBN -> expr_response (step_with Eval.find_redex_cbn expr)
-    | `StepCBV -> expr_response (step_with Eval.find_redex_cbv expr)
+    | `StepCBN ->
+        expr_response ~note:"After one CBN step:"
+          (step_with Eval.find_redex_cbn expr)
+    | `StepCBV ->
+        expr_response ~note:"After one CBV step:"
+          (step_with Eval.find_redex_cbv expr)
     | `DrawTree -> `Graphviz (Draw_tree.draw_tree expr)
     | `RunCBN | `RunCBV -> failwith "not implemented"
   with
+  | Eval.NotARedex expr -> `Error ("not a redex: " ^ show_expr expr)
   | Failure msg -> `Error msg
   | exn -> `Error ("uncaught exception: " ^ Printexc.to_string exn)
diff --git a/discocaml/eval.ml b/discocaml/eval.ml
index 9c12003..f8f7dc2 100644
--- a/discocaml/eval.ml
+++ b/discocaml/eval.ml
@@ -38,6 +38,17 @@ let find_redex_cbv (ast : expr ast) : expr index option =
 let find_redex_cbn (ast : expr ast) : expr index option =
   find_redex_cbn_in ast ast.root
 
-let reduce (ast : expr ast) (_i : expr index) : expr ast =
+exception NotARedex of expr ast
+
+let reduce (ast : expr ast) (i : expr index) : expr ast =
+  let fail () = raise (NotARedex { ast with root = i }) in
   let ast = copy ast in
+  let must_int j = match get_subexpr ast j with Int n -> n | _ -> fail () in
+  Arraylist.set ast.subexprs i.index
+    (match get_subexpr ast i with
+    | App (_f, _x) -> failwith "TODO"
+    | Prim (Add, (l, r)) -> Int (must_int l + must_int r)
+    | Prim (Sub, (l, r)) -> Int (must_int l - must_int r)
+    | Prim (Mul, (l, r)) -> Int (must_int l * must_int r)
+    | _ -> fail ());
   ast
-- 
cgit v1.2.3