Debug prints for the new typer: output JSON

debug.cmd

@@ -0,0 +1 @@
+(echo '['; sed -ne '/###############################START_OF_JSON/,/###############################END_OF_JSON/{/^###############################.*_OF_JSON/d;p}' < '/home/suzanne/00ligopam/ligo/_build/default/src/test/_build/_tests/'*'/Integration (End to End).001.output'; echo '"end of json"]') > /tmp/js.json

src/main/compile/of_core.ml

@@ -18,7 +18,6 @@ let compile (cform: form) (program : Ast_core.program) : (Ast_typed.program * Ty
 let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem.Solver_types.typer_state) (e : Ast_core.expression)
     : (Ast_typed.expression * Typesystem.Solver_types.typer_state , _) result =
   let%bind (ae_typed,state) = trace typer_tracer @@ Typer.type_expression_subst env state e in
-  let () = Typer.Solver.discard_state state in
   let%bind ae_typed' = trace self_ast_typed_tracer @@ Self_ast_typed.all_expression ae_typed in
   ok @@ (ae_typed',state)
 

src/passes/09-typing/08-typer-new/typer.ml

@@ -443,9 +443,9 @@ let type_program_returns_state ((env, state, p) : environment * O'.typer_state *
 let print_env_state_node (node_printer : Format.formatter -> 'a -> unit) ((env,state,node) : environment * O'.typer_state * 'a) =
   ignore node; (* TODO *)
   Printf.printf "%s" @@
-    Format.asprintf "ENV = %a\nSTATE = %a\nNODE = %a\n\n"
-      Ast_typed.PP_generic.environment env
-      Typesystem.Solver_types.pp_typer_state state
+    Format.asprintf "{ \"ENV\": %a,\n\"STATE\": %a,\n\"NODE\": %a\n},\n"
+      Ast_typed.PP_json.environment env
+      Typesystem.Solver_types.json_typer_state state
       node_printer node
 
 let type_and_subst_xyz
@@ -455,20 +455,21 @@ let type_and_subst_xyz
       (apply_substs : ('b , Typer_common.Errors.typer_error) Typesystem.Misc.Substitution.Pattern.w)
       (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b , typer_error) Trace.result)
     : ('b * O'.typer_state , typer_error) result =
+  let () = (if Ast_typed.Debug.json_new_typer then Printf.printf "%!\n###############################START_OF_JSON\n[%!") in
   let () = (if Ast_typed.Debug.debug_new_typer then Printf.printf "\nTODO AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA Print env_state_node here.\n\n") in
-  let () = (if Ast_typed.Debug.debug_new_typer then print_env_state_node in_printer env_state_node) in
+  let () = (if Ast_typed.Debug.debug_new_typer || Ast_typed.Debug.json_new_typer then print_env_state_node in_printer env_state_node) in
   let%bind (env, state, node) = type_xyz_returns_state env_state_node in
   let subst_all =
     let aliases = state.structured_dbs.aliases in
     let assignments = state.structured_dbs.assignments in
     let substs : variable: I.type_variable -> _ = fun ~variable ->
       to_option @@
-      let () = (if Ast_typed.Debug.debug_new_typer then Printf.printf "%s" @@ Format.asprintf "TRY   %a\n" Var.pp variable) in
+      let () = (if Ast_typed.Debug.debug_new_typer then Printf.fprintf stderr "%s" @@ Format.asprintf "TRY   %a\n" Var.pp variable) in
       let%bind root =
         trace_option (corner_case (Format.asprintf "can't find alias root of variable %a" Var.pp variable)) @@
           (* TODO: after upgrading UnionFind, this will be an option, not an exception. *)
           try Some (Solver.UF.repr variable aliases) with Not_found -> None in
-      let () = (if Ast_typed.Debug.debug_new_typer then Printf.printf "%s" @@ Format.asprintf "TRYR  %a (%a)\n" Var.pp variable Var.pp root) in
+      let () = (if Ast_typed.Debug.debug_new_typer then Printf.fprintf stderr "%s" @@ Format.asprintf "TRYR  %a (%a)\n" Var.pp variable Var.pp root) in
       let%bind assignment =
         trace_option (corner_case (Format.asprintf "can't find assignment for root %a" Var.pp root)) @@
           (Map.find_opt root assignments) in
@@ -476,21 +477,22 @@ let type_and_subst_xyz
       let () = ignore tv (* I think there is an issue where the tv is stored twice (as a key and in the element itself) *) in
       let%bind (expr : O.type_content) = trace_option (corner_case "wrong constant tag") @@
         Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.t_variable s ()) tv_list)) in
-      let () = (if Ast_typed.Debug.debug_new_typer then Printf.printf "%s" @@ Format.asprintf "SUBST %a (%a is %a)\n" Var.pp variable Var.pp root Ast_typed.PP_generic.type_content expr) in
+      let () = (if Ast_typed.Debug.debug_new_typer then Printf.fprintf stderr "%s" @@ Format.asprintf "SUBST %a (%a is %a)\n" Var.pp variable Var.pp root Ast_typed.PP_generic.type_content expr) in
       ok @@ expr
     in
     let p = apply_substs ~substs node in
     p in
   let%bind node = subst_all in
   let () = (if Ast_typed.Debug.debug_new_typer then Printf.printf "\nTODO AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA Print env,state,node here again.\n\n") in
-  let () = (if Ast_typed.Debug.debug_new_typer then print_env_state_node out_printer (env, state, node)) in
+  let () = (if Ast_typed.Debug.debug_new_typer || Ast_typed.Debug.json_new_typer then print_env_state_node out_printer (env, state, node)) in
+  let () = (if Ast_typed.Debug.json_new_typer then Printf.printf "%!\"end of JSON\"],\n###############################END_OF_JSON\n%!") in
   let () = ignore env in        (* TODO: shouldn't we use the `env` somewhere? *)
   ok (node, state)
 
 let type_program (p : I.program) : (O.program * O'.typer_state, typer_error) result =
   let empty_env = DEnv.default in
   let empty_state = Solver.initial_state in
-  type_and_subst_xyz I.PP.program Ast_typed.PP_generic.program (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
+  type_and_subst_xyz (fun ppf _v -> Format.fprintf ppf "\"no JSON yet for I.PP.program\"") Ast_typed.PP_json.program (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
 
 let type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) result =
   fun (env, state, e) ->
@@ -499,7 +501,7 @@ let type_expression_returns_state : (environment * O'.typer_state * I.expression
 
 let type_expression_subst (env : environment) (state : O'.typer_state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * O'.typer_state , typer_error) result =
   let () = ignore tv_opt in     (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
-  type_and_subst_xyz I.PP.expression Ast_typed.PP_generic.expression (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
+  type_and_subst_xyz (fun ppf _v -> Format.fprintf ppf "\"no JSON yet for I.PP.expression\"") Ast_typed.PP_json.expression (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
 
 let untype_type_expression  = Untyper.untype_type_expression
 let untype_expression       = Untyper.untype_expression

src/stages/common/debug.ml

@@ -1 +1,2 @@
 let debug_new_typer = false
+let json_new_typer = false