Debug prints for the new typer: output JSON
This commit is contained in:
parent
1cc64d6812
commit
c1d211d98c
1
debug.cmd
Normal file
1
debug.cmd
Normal file
@ -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
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -1 +1,2 @@
|
||||
let debug_new_typer = false
|
||||
let json_new_typer = false
|
||||
|
Loading…
Reference in New Issue
Block a user