From a3c0c366e6f6d97450c47bf2b526807dc7d0f04d Mon Sep 17 00:00:00 2001
From: Louis Gesbert <louis.gesbert@ocamlpro.com>
Date: Tue, 4 Jul 2023 18:31:52 +0200
Subject: [PATCH] Some code simplification

We now have all the functions to factorise this code
---
 compiler/lcalc/compile_with_exceptions.ml | 87 +++--------------------
 1 file changed, 9 insertions(+), 78 deletions(-)

diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml
index 9d6eb958..b0e5ad46 100644
--- a/compiler/lcalc/compile_with_exceptions.ml
+++ b/compiler/lcalc/compile_with_exceptions.ml
@@ -19,11 +19,6 @@ open Shared_ast
 module D = Dcalc.Ast
 module A = Ast
 
-type 'm ctx = unit
-(** This translation no longer needs a context at the moment, but we keep
-    passing the argument through the functions in case the need arises with
-    further evolutions. *)
-
 let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
   let dummy_var = Var.make "_" in
   let pos = Expr.pos e in
@@ -33,13 +28,12 @@ let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
 let translate_var : 'm D.expr Var.t -> 'm A.expr Var.t = Var.translate
 
 let rec translate_default
-    (ctx : 'm ctx)
     (exceptions : 'm D.expr list)
     (just : 'm D.expr)
     (cons : 'm D.expr)
     (mark_default : 'm mark) : 'm A.expr boxed =
   let exceptions =
-    List.map (fun except -> thunk_expr (translate_expr ctx except)) exceptions
+    List.map (fun except -> thunk_expr (translate_expr except)) exceptions
   in
   let pos = Expr.mark_pos mark_default in
   let exceptions =
@@ -49,92 +43,29 @@ let rec translate_default
          (Expr.no_mark mark_default))
       [
         Expr.earray exceptions mark_default;
-        thunk_expr (translate_expr ctx just);
-        thunk_expr (translate_expr ctx cons);
+        thunk_expr (translate_expr just);
+        thunk_expr (translate_expr cons);
       ]
       pos
   in
   exceptions
 
-and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
+and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
   let m = Mark.get e in
   match Mark.remove e with
   | EEmptyError -> Expr.eraise EmptyError m
   | EErrorOnEmpty arg ->
-    Expr.ecatch (translate_expr ctx arg) EmptyError
+    Expr.ecatch (translate_expr arg) EmptyError
       (Expr.eraise NoValueProvided m)
       m
   | EDefault { excepts; just; cons } ->
-    translate_default ctx excepts just cons (Mark.get e)
+    translate_default excepts just cons (Mark.get e)
   | EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
   | ( ELit _ | EApp _ | EArray _ | EVar _ | EExternal _ | EAbs _ | EIfThenElse _
     | ETuple _ | ETupleAccess _ | EInj _ | EAssert _ | EStruct _
     | EStructAccess _ | EMatch _ ) as e ->
-    Expr.map ~f:(translate_expr ctx) (Mark.add m e)
+    Expr.map ~f:translate_expr (Mark.add m e)
   | _ -> .
 
-let rec translate_scope_lets
-    (decl_ctx : decl_ctx)
-    (ctx : 'm ctx)
-    (scope_lets : 'm D.expr scope_body_expr) :
-    'm A.expr scope_body_expr Bindlib.box =
-  match scope_lets with
-  | Result e ->
-    Bindlib.box_apply (fun e -> Result e) (Expr.Box.lift (translate_expr ctx e))
-  | ScopeLet scope_let ->
-    let scope_let_var, scope_let_next =
-      Bindlib.unbind scope_let.scope_let_next
-    in
-    let new_scope_let_expr = translate_expr ctx scope_let.scope_let_expr in
-    let new_scope_next = translate_scope_lets decl_ctx ctx scope_let_next in
-    let new_scope_next =
-      Bindlib.bind_var (translate_var scope_let_var) new_scope_next
-    in
-    Bindlib.box_apply2
-      (fun new_scope_next new_scope_let_expr ->
-        ScopeLet
-          {
-            scope_let_typ = scope_let.scope_let_typ;
-            scope_let_kind = scope_let.scope_let_kind;
-            scope_let_pos = scope_let.scope_let_pos;
-            scope_let_next = new_scope_next;
-            scope_let_expr = new_scope_let_expr;
-          })
-      new_scope_next
-      (Expr.Box.lift new_scope_let_expr)
-
-let translate_items
-    (decl_ctx : decl_ctx)
-    (ctx : 'm ctx)
-    (scopes : 'm D.expr code_item_list) : 'm A.expr code_item_list Bindlib.box =
-  Scope.map_ctx
-    ~f:
-      (fun ctx -> function
-        | Topdef (name, ty, e) ->
-          ( ctx,
-            Bindlib.box_apply
-              (fun e -> Topdef (name, ty, e))
-              (Expr.Box.lift (translate_expr ctx e)) )
-        | ScopeDef (name, body) ->
-          let scope_input_var, body_expr =
-            Bindlib.unbind body.scope_body_expr
-          in
-          let new_scope_body_expr =
-            translate_scope_lets decl_ctx ctx body_expr
-          in
-          let new_body =
-            Bindlib.bind_var (translate_var scope_input_var) new_scope_body_expr
-          in
-          ( ctx,
-            Bindlib.box_apply
-              (fun scope_body_expr ->
-                ScopeDef (name, { body with scope_body_expr }))
-              new_body ))
-    ~varf:translate_var ctx scopes
-
-let translate_program (prgm : 'm D.program) : 'm A.program =
-  {
-    code_items =
-      Bindlib.unbox (translate_items prgm.decl_ctx () prgm.code_items);
-    decl_ctx = prgm.decl_ctx;
-  }
+let translate_program (prg : 'm D.program) : 'm A.program =
+  Bindlib.unbox (Program.map_exprs ~f:translate_expr ~varf:translate_var prg)