From c1d211d98c71ff06b47cae0eed3eadae8b71e3cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 17 Jun 2020 22:39:14 +0100 Subject: [PATCH] Debug prints for the new typer: output JSON --- debug.cmd | 1 + src/main/compile/of_core.ml | 1 - src/passes/09-typing/08-typer-new/typer.ml | 22 ++++++++++++---------- src/stages/common/debug.ml | 1 + 4 files changed, 14 insertions(+), 11 deletions(-) create mode 100644 debug.cmd diff --git a/debug.cmd b/debug.cmd new file mode 100644 index 000000000..b22905ed0 --- /dev/null +++ b/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 diff --git a/src/main/compile/of_core.ml b/src/main/compile/of_core.ml index 931aee07d..8f580f153 100644 --- a/src/main/compile/of_core.ml +++ b/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) diff --git a/src/passes/09-typing/08-typer-new/typer.ml b/src/passes/09-typing/08-typer-new/typer.ml index 33462feae..6b690ceb5 100644 --- a/src/passes/09-typing/08-typer-new/typer.ml +++ b/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 diff --git a/src/stages/common/debug.ml b/src/stages/common/debug.ml index 6e435e395..a87e6cb46 100644 --- a/src/stages/common/debug.ml +++ b/src/stages/common/debug.ml @@ -1 +1,2 @@ let debug_new_typer = false +let json_new_typer = false