more

ocamli2/eval.ml

@@ -139,7 +139,7 @@ let type_ocaml_heap_value = function
  *
  * List.map (fun x -> x + 1) [1; 2; 3] *)
 let mkempty lets e =
-  {e; lets; peek = None; printas = None; typ = {desc = Types.Tvar (Some "DEBUG-mkempty"); level = 0; scope = 0; id = 0}}
+  {e; lets; peek = None; printbefore = None; printafter = None; printas = None; typ = {desc = Types.Tvar (Some "DEBUG-mkempty"); level = 0; scope = 0; id = 0}}
 
 let rec make_native impl_lets funexpr =
   match funexpr with
@@ -150,6 +150,7 @@ let rec make_native impl_lets funexpr =
           {rhs with lets = impl_lets; e = Apply (funexpr, [{rhs with e = Var vname}])}
         in
           fun x ->
+            Printf.printf "{entering %s}\n" (Print.to_string funexpr);
             let newlet = (false, ref [(vname, {expr with e = Value x; typ = beta})]) in
              let r =
                 match ((eval_full (newlet::fenv)) expr).e with
@@ -160,11 +161,18 @@ let rec make_native impl_lets funexpr =
                 | _ -> 
                     failwith "didn't make a value"
              in
+               Printf.printf "{leaving %s}\n" (Print.to_string funexpr);
                r
       in
         (Obj.magic fn : Obj.t)
   | _ -> failwith "make_native not a function"
 
+and print_before expr =
+  match expr.printbefore with None -> () | Some x -> print_string x
+
+and print_after expr =
+  match expr.printafter with None -> () | Some x -> print_string x
+
 and eval env peek expr =
   if !showrules then print_string "RULE: ";
   let env = List.rev expr.lets @ env in
@@ -234,6 +242,8 @@ and eval env peek expr =
              typ = exp.typ;
              lets = expr.lets @ [(recflag, ref [(n, evalled)])] @ exp'.lets;
              peek = expr.peek;
+             printbefore = None;
+             printafter = None;
              printas = None}
           else {expr with e = Let (recflag, (n, evalled), exp')}
 | ArrayExpr a ->
@@ -349,6 +359,7 @@ and eval env peek expr =
     end
 | Apply ({e = Value f} as lhs, ({e = Function _} as fi)::more) ->
     if !showrules then print_endline "Apply-BuiltIn-Interp";
+    print_before lhs;
     if peek then underline expr else
       let typ =
         match lhs.typ.desc with Tarrow (_, _, b, _) -> b | _ -> expr.typ (* Actually a failure, probably *)
@@ -379,7 +390,9 @@ and eval env peek expr =
             match lhs.typ.desc with Tarrow (_, _, b, _) -> b | _ -> expr.typ (* Actually a failure, probably *)
           in
             if more = [] then
-              {expr with e = Value ((Obj.magic f : Obj.t -> Obj.t) v); printas; typ}
+              let r = {expr with e = Value ((Obj.magic f : Obj.t -> Obj.t) v); printas; typ} in
+              print_after lhs;
+              r
             else
               {expr with
                 e = Apply ({lhs with typ; e = Value ((Obj.magic f : Obj.t -> Obj.t) v)}, more)}

ocamli2/lib.ml

@@ -6,6 +6,8 @@ let f name func =
        lets = [];
        typ = {level = 0; scope = 0; id = 0; desc = Types.Tvar (Some "DEBUG-lib.ml")};
        printas = Some name;
+       printbefore = Some ("{entering " ^ name ^ "}\n");
+       printafter = Some ("{leaving " ^ name ^ "}\n");
        peek = None}
   in
     (false, ref [("Stdlib." ^ name, e)])

ocamli2/print.ml

@@ -173,7 +173,7 @@ let rec string_of_value v = function
 
 and fakelet =
   {e = Let (false, ("fakelet", fakelet), fakelet);
-   lets = []; peek = None; printas = None; typ = {level = 0; scope = 0; id = 0; desc = Tvar (Some "DEBUG-fakelet")}}
+   lets = []; peek = None; printbefore = None; printafter = None; printas = None; typ = {level = 0; scope = 0; id = 0; desc = Tvar (Some "DEBUG-fakelet")}}
 
 (* Find the names of functions which are candidates for abbreviation, and return the expression below *)
 and find_funs x =
@@ -308,13 +308,13 @@ and print_finaltype_inner f isleft parent node =
   | Function (cases, _) ->
       str lp;
       boldstr "function";
-      if lp = "" then newline ();
+      (*if lp = "" then newline ();*)
       let first = ref true in
       let l = List.length cases in
       List.iteri
        (fun i (pat, _, rhs) ->
          if !first then
-           (if lp = "(" then str " " else str "  ") else
+           (if lp = "(" || l = 1 then str " " else str "  ") else
            (if lp = "(" then str " | " else str "| ");
          first := false;
          print_finaltype_pattern f false (Some node) pat;
@@ -467,6 +467,8 @@ and to_string_from_heap typ v =
      lets = [];
      typ = typ;
      peek = None;
+     printbefore = None;
+     printafter = None;
      printas = None}
 
 and string_of_t_show_types = ref true

ocamli2/read.ml

@@ -93,7 +93,7 @@ let rec finaltype_of_expression_desc typ env = function
       Cons (finaltype_of_expression env h, finaltype_of_expression env t)
     in
       if should_be_value_funfalse_t' cons_chain
-        then Value (to_ocaml_heap_value {typ; lets = []; peek = None; printas = None; e = cons_chain})
+        then Value (to_ocaml_heap_value {typ; lets = []; peek = None; printbefore = None; printafter = None; printas = None; e = cons_chain})
         else cons_chain
 | Texp_let (recflag, [binding], e) ->
     let (var, expr) = finaltype_of_binding env binding
@@ -151,7 +151,7 @@ let rec finaltype_of_expression_desc typ env = function
 | Texp_array es ->
     let arr = Array.of_list (List.map (finaltype_of_expression env) es) in
       if should_be_value_funfalse_t' (ArrayExpr arr) then
-        Value (to_ocaml_heap_value {typ; lets = []; peek = None; printas = None; e = ArrayExpr arr})
+        Value (to_ocaml_heap_value {typ; lets = []; peek = None; printafter = None; printbefore = None; printas = None; e = ArrayExpr arr})
       else
         ArrayExpr arr
 | Texp_match (a, cases, _) ->
@@ -190,6 +190,8 @@ and finaltype_of_expression env exp =
        typ = typ;
        lets = [];
        peek = None;
+       printbefore = None;
+       printafter = None;
        printas = None}
   with
     IsImplicitLet (var, expr, expr') ->
@@ -215,12 +217,16 @@ let finaltype_of_typedtree {str_items} =
                    lets = [];
                    typ = debug_type (remove_links vb.vb_expr.exp_type);
                    peek = None;
+                   printbefore = None;
+                   printafter = None;
                    printas = None}
             | _ -> failwith "finaltype_of_typedtree")
           str_items);
        lets = [];
        typ = {level = 0; id = 0; scope = 0; desc = Types.Tnil};
        peek = None;
+       printbefore = None;
+       printafter = None;
        printas = None} (* FIXME: Proper support for signature types *)
 
 let env =

ocamli2/tppxsupport.ml

@@ -34,12 +34,21 @@ let eval_full env x =
       {Type.e = Type.Value x} -> x
     | x -> to_ocaml_heap_value x
 
+let eval_full_from_typedtree env x =
+  let typedtree = (Marshal.from_string x 0 : Typedtree.expression) in
+    let program = Read.finaltype_of_expression !env typedtree in
+      match Eval.eval_full !env program with
+        {Type.e = Type.Value x} -> x
+      | x -> to_ocaml_heap_value x
+
 let addenv envref printas n v t =
   let binding =
     {Type.e = Type.Value v;
      Type.typ = Read.debug_type (Read.remove_links (Marshal.from_string t 0 : Types.type_expr));
      Type.lets = [];
      Type.peek = None;
+     Type.printbefore = None;
+     Type.printafter = None;
      Type.printas = printas}
   in
     envref := (false, ref [(n, binding)])::!envref

ocamli2/tppxsupport.mli

@@ -1,5 +1,7 @@
 val eval_full : Type.env ref -> string -> Obj.t
 
+val eval_full_from_typedtree : Type.env ref -> string -> Obj.t
+
 val addenv : Type.env ref -> string option -> string -> Obj.t -> string -> unit
 
 val init : unit -> unit

ocamli2/type.ml

@@ -42,7 +42,9 @@ and t =
    e : t';
    lets : env;
    peek : peekinfo option;
-   printas : string option}
+   printas : string option;
+   printbefore : string option;
+   printafter : string option}
 
 and env = envitem list
 

ocamli2/type.mli

@@ -40,7 +40,9 @@ and t =
    e : t';
    lets : env;
    peek : peekinfo option;
-   printas : string option}
+   printas : string option;
+   printbefore : string option;
+   printafter : string option}
 
 and env = envitem list