Merge pull request #83 from jO-Osko/toplevel-ocaml-handler-fix

Fixes value restriction on toplevel handlers

src/05-backends/plain-ocaml/translateNoEff2Ocaml.ml

@@ -176,7 +176,7 @@ let pp_lets keyword pp_let_def lst ppf =
 let pp_coercion_vars ws =
   Print.sequence " " (Type.TyCoercionParam.print ~safe:true) ws
 
-let rec pp_term ?max_level state noEff_term ppf =
+let rec pp_term ?max_level ?(top_level = false) state noEff_term ppf =
   let print ?at_level = Print.print ?max_level ?at_level ppf in
   match noEff_term with
   | NVar v when v.coercions = [] -> print "%t" (pp_variable state v.variable)
@@ -216,12 +216,26 @@ let rec pp_term ?max_level state noEff_term ppf =
         (pp_term state ~max_level:0 t)
   | NReturn t -> print ~at_level:1 "Value %t" (pp_term state ~max_level:0 t)
   | NHandler { effect_clauses; return_clause; finally_clause } ->
-      print ~at_level:2
-        "handler {@[<hov>value_clause = (fun %t);@] @[<hov>effect_clauses = \
-         %t;@]} (@[<hov>(fun %t)@])"
-        (pp_abs_with_ty state return_clause)
-        (pp_effect_cls state effect_clauses)
-        (pp_abs_with_ty state finally_clause)
+      (* Top level handlers need to be printed in a fully applied form,
+         otherwise value restriction kicks in when compiling the
+         resulting files with OCaml*)
+      if top_level then
+        let v = Variable.fresh "cmd" in
+        print ~at_level:2
+          "(fun %t -> handler {@[<hov>value_clause = (fun %t);@] \
+           @[<hov>effect_clauses = %t;@]} (@[<hov>(fun %t)@]) %t)"
+          (pp_variable state v)
+          (pp_abs_with_ty state return_clause)
+          (pp_effect_cls state effect_clauses)
+          (pp_abs_with_ty state finally_clause)
+          (pp_term state (SyntaxNoEff.NVar { variable = v; coercions = [] }))
+      else
+        print ~at_level:2
+          "handler {@[<hov>value_clause = (fun %t);@] @[<hov>effect_clauses = \
+           %t;@]} (@[<hov>(fun %t)@])"
+          (pp_abs_with_ty state return_clause)
+          (pp_effect_cls state effect_clauses)
+          (pp_abs_with_ty state finally_clause)
   | NLet (t1, (pat, t2)) ->
       print ~at_level:2 "@[<hv>@[<hv>let %t = %t in@] @,%t@]"
         (pp_pattern state pat) (pp_term state t1) (pp_term state t2)
@@ -317,9 +331,9 @@ let pp_def_effect (eff, (ty1, ty2)) ppf =
      @]@.;;"
     (Effect.print eff) (pp_type ty1) (pp_type ty2)
 
-let pp_let_def state (p, ws, t) ppf =
+let pp_let_def ?(top_level = false) state (p, ws, t) ppf =
   print ppf "%t %t = @,%t" (pp_pattern state p) (pp_coercion_vars ws)
-    (pp_term state t)
+    (pp_term ~top_level state t)
 
 let pp_external state name symbol_name ppf =
   print ppf "let %t = ( %s )@.;;" (pp_variable state name) symbol_name
@@ -355,7 +369,7 @@ let pp_cmd state cmd ppf =
   | DefEffect e -> pp_def_effect e ppf
   | TopLet defs ->
       print ppf "%t@.;; let %t = %t@.;;"
-        (pp_lets "let" (pp_let_def state) defs)
+        (pp_lets "let" (pp_let_def ~top_level:true state) defs)
         (Print.sequence ","
            (fun (f, _, _) -> pp_pattern ~safe:false state f)
            defs)

tests/codegen/reuse_toplevel_handler.eff

@@ -0,0 +1,8 @@
+let h = handler 
+  | x -> x
+;;
+(* If the value restriction kicks in, handler types won't match)   *)
+with h handle 1
+;;
+
+with h handle (1,2)

tests/format_generated_code.t

@@ -2096,7 +2096,7 @@
   let fail = _fail
 
   let _parse _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer
-      _tycoer _tycoer _tycoer _tycoer =
+      _tycoer _tycoer _tycoer _tycoer _cmd =
     handler
       {
         value_clause =
@@ -2139,10 +2139,12 @@
         coer_return
           (coer_arrow coer_refl_ty (coer_computation _tycoer))
           (coer_arrow coer_refl_ty (coer_computation _tycoer) _x))
+      _cmd
   
   let parse = _parse
   
-  let _allsols _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer =
+  let _allsols _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer _tycoer
+      _cmd =
     handler
       {
         value_clause =
@@ -2165,10 +2167,11 @@
       }
       (fun (_x : 'ty124 list) ->
         coer_return (coer_list _tycoer) (coer_list _tycoer _x))
+      _cmd
   
   let allsols = _allsols
   
-  let _backtrack _tycoer _tycoer _tycoer =
+  let _backtrack _tycoer _tycoer _tycoer _cmd =
     handler
       {
         value_clause = (fun (_id : 'ty152) -> coer_return _tycoer _id);
@@ -2193,6 +2196,7 @@
             | eff' -> fun arg k -> Call (eff', arg, k));
       }
       (fun (_x : 'ty155) -> coer_return _tycoer (_tycoer _x))
+      _cmd
   
   let backtrack = _backtrack
   
@@ -3094,6 +3098,62 @@
 
   let test_simple2 = _test_simple2
   ======================================================================
+  codegen/reuse_toplevel_handler.eff
+  ----------------------------------------------------------------------
+  (* primitive effect *)
+
+  type (_, _) eff_internal_effect += Print : (string, unit) eff_internal_effect
+
+  (* primitive effect *)
+
+  type (_, _) eff_internal_effect += Read : (unit, string) eff_internal_effect
+
+  (* primitive effect *)
+
+  type (_, _) eff_internal_effect += Raise : (string, empty) eff_internal_effect
+
+  (* primitive effect *)
+
+  type (_, _) eff_internal_effect += RandomInt : (int, int) eff_internal_effect
+
+  (* primitive effect *)
+
+  type (_, _) eff_internal_effect +=
+    | RandomFloat : (float, float) eff_internal_effect
+
+  (* primitive effect *)
+
+  type (_, _) eff_internal_effect +=
+    | Write : (string * string, unit) eff_internal_effect
+
+  let _h _tycoer _tycoer _tycoer _tycoer _tycoer _cmd =
+    handler
+      {
+        value_clause =
+          (fun (_x : 'ty6) ->
+            coer_computation _tycoer (coer_return _tycoer (_tycoer _x)));
+        effect_clauses =
+          (fun (type a b) (eff : (a, b) eff_internal_effect) :
+               (a -> (b -> _) -> _) ->
+            match eff with eff' -> fun arg k -> Call (eff', arg, k));
+      }
+      (fun (_x : 'ty4) -> coer_return _tycoer (_tycoer _x))
+      _cmd
+  
+  let h = _h
+  
+  ;;
+  _h coer_refl_ty coer_refl_ty coer_refl_ty coer_refl_ty coer_refl_ty (Value 1)
+  
+  ;;
+  _h
+    (coer_tuple (coer_refl_ty, coer_refl_ty))
+    coer_refl_ty
+    (coer_tuple (coer_refl_ty, coer_refl_ty))
+    coer_refl_ty
+    (coer_tuple (coer_refl_ty, coer_refl_ty))
+    (Value (1, 2))
+  ======================================================================
   codegen/substitution.eff
   ----------------------------------------------------------------------
   (* primitive effect *)

tests/run_generated_code.t

@@ -108,6 +108,9 @@
   codegen/redefine_local.eff
   ----------------------------------------------------------------------
   ======================================================================
+  codegen/reuse_toplevel_handler.eff
+  ----------------------------------------------------------------------
+  ======================================================================
   codegen/substitution.eff
   ----------------------------------------------------------------------
   ======================================================================