balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add a pretty-printer to the heuristics

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-06-17 22:59:35 +01:00
parent 018e269b2e
commit bd8a57df44
5 changed files with 71 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml
View File

@ -51,4 +51,11 @@ let propagator : output_break_ctor propagator =
let eqs = eq1 :: eqs3 in
(eqs , []) (* no new assignments *)
let heuristic = Propagator_heuristic { selector ; propagator ; comparator = Solver_should_be_generated.compare_output_break_ctor }
let heuristic =
Propagator_heuristic
{
selector ;
propagator ;
printer = Ast_typed.PP_generic.output_break_ctor ; (* TODO: use an accessor that can get the printer for PP_generic or PP_json alike *)
comparator = Solver_should_be_generated.compare_output_break_ctor
}

9
src/passes/09-typing/08-typer-new/heuristic_specialize1.ml
View File

@ -52,4 +52,11 @@ let propagator : output_specialize1 propagator =
let eqs = eq1 :: new_constraints in
(eqs, []) (* no new assignments *)
let heuristic = Propagator_heuristic { selector ; propagator ; comparator = Solver_should_be_generated.compare_output_specialize1 }
let heuristic =
Propagator_heuristic
{
selector ;
propagator ;
printer = Ast_typed.PP_generic.output_specialize1 ;
comparator = Solver_should_be_generated.compare_output_specialize1
}

8
src/passes/09-typing/08-typer-new/solver.ml
View File

@ -13,8 +13,8 @@ let propagator_heuristics =
Heuristic_specialize1.heuristic ;
]
let init_propagator_heuristic (Propagator_heuristic { selector ; propagator ; comparator }) =
Propagator_state { selector ; propagator ; already_selected = Set.create ~cmp:comparator }
let init_propagator_heuristic (Propagator_heuristic { selector ; propagator ; printer ; comparator }) =
Propagator_state { selector ; propagator ; printer ; already_selected = Set.create ~cmp:comparator }
let initial_state : typer_state = {
structured_dbs =
@ -49,12 +49,12 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_
| WasNotSelected ->
(already_selected, [] , [])
let select_and_propagate_one new_constraint (new_states , new_constraints , dbs) (Propagator_state { selector; propagator; already_selected }) =
let select_and_propagate_one new_constraint (new_states , new_constraints , dbs) (Propagator_state { selector; propagator; printer ; already_selected }) =
let sel_propag = (select_and_propagate selector propagator) in
let (already_selected , new_constraints', new_assignments) = sel_propag already_selected new_constraint dbs in
let assignments = List.fold_left (fun acc ({tv;c_tag=_;tv_list=_} as ele) -> Map.update tv (function None -> Some ele | x -> x) acc) dbs.assignments new_assignments in
let dbs = { dbs with assignments } in
Propagator_state { selector; propagator; already_selected } :: new_states, new_constraints' @ new_constraints, dbs
Propagator_state { selector; propagator; printer ; already_selected } :: new_states, new_constraints' @ new_constraints, dbs
(* Takes a constraint, applies all selector+propagator pairs to it.
Keeps track of which constraints have already been selected. *)

22
src/passes/09-typing/08-typer-new/typer.ml
View File

@ -440,9 +440,21 @@ let type_program_returns_state ((env, state, p) : environment * O'.typer_state *
let declarations = List.rev declarations in (* Common hack to have O(1) append: prepend and then reverse *)
ok (env', state', declarations)
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
node_printer node
let type_and_subst_xyz
(env_state_node : environment * O'.typer_state * 'a) (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 =
(in_printer : Format.formatter -> 'a -> unit)
(out_printer : Format.formatter -> 'b -> unit)
(env_state_node : environment * O'.typer_state * 'a)
(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%bind (env, state, node) = type_xyz_returns_state env_state_node in
let subst_all =
let aliases = state.structured_dbs.aliases in
@ -471,7 +483,7 @@ let type_and_subst_xyz
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 (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
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
let type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) result =
fun (env, state, e) ->
@ -480,7 +492,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 (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
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
let untype_type_expression = Untyper.untype_type_expression
let untype_expression = Untyper.untype_expression
@ -493,7 +505,7 @@ and [@warning "-32"] type_expression : environment -> O'.typer_state -> ?tv_opt:
and [@warning "-32"] type_lambda e state lam = type_lambda e state lam
and [@warning "-32"] type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression, typer_error) result = type_constant name lst tv_opt
let [@warning "-32"] type_program_returns_state ((env, state, p) : environment * O'.typer_state * I.program) : (environment * O'.typer_state * O.program, typer_error) result = type_program_returns_state (env, state, p)
let [@warning "-32"] type_and_subst_xyz (env_state_node : environment * O'.typer_state * 'a) (apply_substs : ('b,typer_error) Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b, typer_error) result) : ('b * O'.typer_state, typer_error) result = type_and_subst_xyz env_state_node apply_substs type_xyz_returns_state
let [@warning "-32"] type_and_subst_xyz (in_printer : (Format.formatter -> 'a -> unit)) (out_printer : (Format.formatter -> 'b -> unit)) (env_state_node : environment * O'.typer_state * 'a) (apply_substs : ('b,typer_error) Typesystem.Misc.Substitution.Pattern.w) (type_xyz_returns_state : (environment * O'.typer_state * 'a) -> (environment * O'.typer_state * 'b, typer_error) result) : ('b * O'.typer_state, typer_error) result = type_and_subst_xyz in_printer out_printer env_state_node apply_substs type_xyz_returns_state
let [@warning "-32"] type_program (p : I.program) : (O.program * O'.typer_state, typer_error) result = type_program p
let [@warning "-32"] type_expression_returns_state : (environment * O'.typer_state * I.expression) -> (environment * O'.typer_state * O.expression, typer_error) Trace.result = type_expression_returns_state
let [@warning "-32"] 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 = type_expression_subst env state ?tv_opt e

34
src/stages/typesystem/solver_types.ml
View File

@ -15,12 +15,14 @@ type ('old_constraint_type , 'selector_output ) propagator_heuristic = {
selector : ('old_constraint_type, 'selector_output) selector ;
(* constraint propagation: (buch of constraints) → (new constraints * assignments) *)
propagator : 'selector_output propagator ;
printer : Format.formatter -> 'selector_output -> unit ;
comparator : 'selector_output -> 'selector_output -> int ;
}
type ('old_constraint_type , 'selector_output ) propagator_state = {
selector : ('old_constraint_type, 'selector_output) selector ;
propagator : 'selector_output propagator ;
printer : Format.formatter -> 'selector_output -> unit ;
already_selected : 'selector_output Set.t;
}
@ -37,6 +39,38 @@ type typer_state = {
already_selected_and_propagators : ex_propagator_state list ;
}
open Format
open PP_helpers
let pp_already_selected = fun printer ppf set ->
let lst = (RedBlackTrees.PolySet.elements set) in
Format.fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep printer (fun ppf () -> fprintf ppf " ;@ ")) lst
let pp_ex_propagator_state = fun ppf (Propagator_state { selector ; propagator ; printer ; already_selected }) ->
ignore ( selector, propagator );
Format.fprintf ppf "{ selector = (* OCaml function *); propagator = (* OCaml function *); already_selected = %a }"
(pp_already_selected printer) already_selected
let pp_typer_state = fun ppf ({ structured_dbs; already_selected_and_propagators } : typer_state) ->
Format.fprintf ppf "{ structured_dbs = %a ; already_selected_and_propagators = [ %a ] }"
Ast_typed.PP_generic.structured_dbs structured_dbs
(list_sep pp_ex_propagator_state (fun ppf () -> fprintf ppf " ;@ ")) already_selected_and_propagators
let json_already_selected = fun printer ppf set ->
let lst = (RedBlackTrees.PolySet.elements set) in
Format.fprintf ppf "[ \"Set\" %a ]" (list_sep printer (fun ppf () -> fprintf ppf " , ")) lst
let json_ex_propagator_state = fun ppf (Propagator_state { selector; propagator; printer ; already_selected }) ->
ignore (selector,propagator);
Format.fprintf ppf "{ \"selector\": \"OCaml function\"; \"propagator\": \"OCaml function\"; \"already_selected\": %a }"
(json_already_selected printer) already_selected
let json_typer_state = fun ppf ({ structured_dbs; already_selected_and_propagators } : typer_state) ->
Format.fprintf ppf "{ \"structured_dbs\": %a ; \"already_selected_and_propagators\": [ %a ] }"
Ast_typed.PP_json.structured_dbs structured_dbs
(list_sep json_ex_propagator_state (fun ppf () -> fprintf ppf " , ")) already_selected_and_propagators
(* state+list monad *)
type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list }
let lift_state_list_monad ~state ~list = { state ; list }