From 018e269b2ebcdd05f8e9b3a685cd8aae561a8cad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 24 Jun 2020 02:04:59 +0100 Subject: [PATCH 01/10] Have separate ppf and Yojson modules for PP_json --- src/stages/5-ast_typed/PP_json.ml | 14 ++++++++++++-- src/stages/5-ast_typed/formatter.ml | 2 +- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/src/stages/5-ast_typed/PP_json.ml b/src/stages/5-ast_typed/PP_json.ml index 745483ebc..d700c65b3 100644 --- a/src/stages/5-ast_typed/PP_json.ml +++ b/src/stages/5-ast_typed/PP_json.ml @@ -76,13 +76,23 @@ module M = struct `Assoc ["typeVariableMap", `List lst'] ); } - let print : ((no_state, json) fold_config -> no_state -> 'a -> json) -> 'a -> json = fun fold v -> + let to_json : ((no_state, json) fold_config -> no_state -> 'a -> json) -> 'a -> json = fun fold v -> fold to_json NoState v + + let print : ((no_state, json) fold_config -> no_state -> 'a -> json) -> formatter -> 'a -> unit = fun fold ppf v -> + fprintf ppf "%a" Yojson.Basic.pp (to_json fold v) end +module Yojson = Fold.Folds(struct + type in_state = M.no_state ;; + type out_state = json ;; + type 'a t = 'a -> json ;; + let f = M.to_json ;; +end) + include Fold.Folds(struct type in_state = M.no_state ;; type out_state = json ;; - type 'a t = 'a -> json ;; + type 'a t = formatter -> 'a -> unit ;; let f = M.print ;; end) diff --git a/src/stages/5-ast_typed/formatter.ml b/src/stages/5-ast_typed/formatter.ml index f6c331722..e42269786 100644 --- a/src/stages/5-ast_typed/formatter.ml +++ b/src/stages/5-ast_typed/formatter.ml @@ -4,7 +4,7 @@ let program_ppformat ~display_format f (typed,_) = match display_format with | Human_readable | Dev -> PP.program f typed -let program_jsonformat (typed,_) : json = PP_json.program typed +let program_jsonformat (typed,_) : json = PP_json.Yojson.program typed let program_format : 'a format = { pp = program_ppformat; From bd8a57df44a76bb7ed9ee3f6e2ab43ace3dbffda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 17 Jun 2020 22:59:35 +0100 Subject: [PATCH 02/10] Add a pretty-printer to the heuristics --- .../08-typer-new/heuristic_break_ctor.ml | 9 ++++- .../08-typer-new/heuristic_specialize1.ml | 9 ++++- src/passes/09-typing/08-typer-new/solver.ml | 8 ++--- src/passes/09-typing/08-typer-new/typer.ml | 22 +++++++++--- src/stages/typesystem/solver_types.ml | 34 +++++++++++++++++++ 5 files changed, 71 insertions(+), 11 deletions(-) diff --git a/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml b/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml index ab8842443..df54b41c8 100644 --- a/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml +++ b/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml @@ -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 + } diff --git a/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml b/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml index 5d7bc863f..8d82cfd3f 100644 --- a/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml +++ b/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml @@ -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 + } diff --git a/src/passes/09-typing/08-typer-new/solver.ml b/src/passes/09-typing/08-typer-new/solver.ml index aa2df6f24..747e56e4d 100644 --- a/src/passes/09-typing/08-typer-new/solver.ml +++ b/src/passes/09-typing/08-typer-new/solver.ml @@ -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. *) diff --git a/src/passes/09-typing/08-typer-new/typer.ml b/src/passes/09-typing/08-typer-new/typer.ml index 8359a281f..3b92319f2 100644 --- a/src/passes/09-typing/08-typer-new/typer.ml +++ b/src/passes/09-typing/08-typer-new/typer.ml @@ -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 diff --git a/src/stages/typesystem/solver_types.ml b/src/stages/typesystem/solver_types.ml index 8c9b547c3..a1c36b56a 100644 --- a/src/stages/typesystem/solver_types.ml +++ b/src/stages/typesystem/solver_types.ml @@ -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 [@,@[ %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 } From 283dcf418a1f212f777542b089ffebae202a3bbd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 17 Jun 2020 23:15:17 +0100 Subject: [PATCH 03/10] Debug prints for the new typer --- .../09-typing/08-typer-new/heuristic_break_ctor.ml | 3 +++ .../09-typing/08-typer-new/heuristic_specialize1.ml | 1 + src/passes/09-typing/08-typer-new/normalizer.ml | 2 +- src/passes/09-typing/08-typer-new/solver.ml | 9 +++++++++ src/passes/09-typing/08-typer-new/typer.ml | 7 +++++++ src/stages/2-ast_imperative/PP.ml | 2 +- src/stages/5-ast_typed/ast_typed.ml | 1 + src/stages/common/ast_common.ml | 1 + src/stages/common/debug.ml | 1 + src/stages/typesystem/core.ml | 6 ++++-- src/test/test_helpers.ml | 2 ++ vendors/ligo-utils/simple-utils/var.ml | 2 ++ vendors/ligo-utils/simple-utils/var.mli | 2 ++ 13 files changed, 35 insertions(+), 4 deletions(-) create mode 100644 src/stages/common/debug.ml diff --git a/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml b/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml index df54b41c8..d140ecdc3 100644 --- a/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml +++ b/src/passes/09-typing/08-typer-new/heuristic_break_ctor.ml @@ -36,6 +36,9 @@ let propagator : output_break_ctor propagator = (* a.tv = b.tv *) let eq1 = c_equation { tsrc = "solver: propagator: break_ctor a" ; t = P_variable a.tv} { tsrc = "solver: propagator: break_ctor b" ; t = P_variable b.tv} "propagator: break_ctor" in + let () = if Ast_typed.Debug.debug_new_typer then + let p = Ast_typed.PP_generic.c_constructor_simpl in + Format.printf "\npropagator_break_ctor\na = %a\nb = %a\n%!" p a p b in (* a.c_tag = b.c_tag *) if (Solver_should_be_generated.compare_simple_c_constant a.c_tag b.c_tag) <> 0 then failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)" diff --git a/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml b/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml index 8d82cfd3f..d9c3563c1 100644 --- a/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml +++ b/src/passes/09-typing/08-typer-new/heuristic_specialize1.ml @@ -48,6 +48,7 @@ let propagator : output_specialize1 propagator = t = P_apply { tf = { tsrc = "solver: propagator: specialize1 tf" ; t = P_forall a.forall }; targ = { tsrc = "solver: propagator: specialize1 targ" ; t = P_variable fresh_existential }} } in let (reduced, new_constraints) = Typelang.check_applied @@ Typelang.type_level_eval apply in + (if Ast_typed.Debug.debug_new_typer then Format.printf "apply = %a\nb = %a\nreduced = %a\nnew_constraints = [\n%a\n]\n" Ast_typed.PP_generic.type_value apply Ast_typed.PP_generic.c_constructor_simpl b Ast_typed.PP_generic.type_value reduced (PP_helpers.list_sep Ast_typed.PP_generic.type_constraint (fun ppf () -> Format.fprintf ppf " ;\n")) new_constraints); let eq1 = c_equation { tsrc = "solver: propagator: specialize1 eq1" ; t = P_variable b.tv } reduced "propagator: specialize1" in let eqs = eq1 :: new_constraints in (eqs, []) (* no new assignments *) diff --git a/src/passes/09-typing/08-typer-new/normalizer.ml b/src/passes/09-typing/08-typer-new/normalizer.ml index 5c6549c03..ecd0c8a5a 100644 --- a/src/passes/09-typing/08-typer-new/normalizer.ml +++ b/src/passes/09-typing/08-typer-new/normalizer.ml @@ -114,7 +114,7 @@ let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer | C_equation {aval=({ tsrc = _ ; t = P_apply _ } as a); bval=(_ as b)} -> reduce_type_app b a (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) | C_typeclass { tc_args; typeclass } -> split_typeclass tc_args typeclass - | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO" (* tv, label, result *) + | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO C_access_label" (* tv, label, result *) let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad = fun new_constraint dbs -> diff --git a/src/passes/09-typing/08-typer-new/solver.ml b/src/passes/09-typing/08-typer-new/solver.ml index 747e56e4d..06ada30f0 100644 --- a/src/passes/09-typing/08-typer-new/solver.ml +++ b/src/passes/09-typing/08-typer-new/solver.ml @@ -45,6 +45,15 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> 'selector_ (* Call the propagation rule *) let (new_constraints , new_assignments) = List.split @@ List.map (propagator dbs) selected_outputs in (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) +let () = + (if Ast_typed.Debug.debug_new_typer && false then + let s str = (fun ppf () -> Format.fprintf ppf str) in + Format.printf "propagator produced\nnew_constraints = %a\nnew_assignments = %a\n" + (PP_helpers.list_sep (PP_helpers.list_sep Ast_typed.PP_generic.type_constraint (s "\n")) (s "\n")) + new_constraints + (PP_helpers.list_sep (PP_helpers.list_sep Ast_typed.PP_generic.c_constructor_simpl (s "\n")) (s "\n")) + new_assignments) +in (already_selected , List.flatten new_constraints , List.flatten new_assignments) | WasNotSelected -> (already_selected, [] , []) diff --git a/src/passes/09-typing/08-typer-new/typer.ml b/src/passes/09-typing/08-typer-new/typer.ml index 3b92319f2..33462feae 100644 --- a/src/passes/09-typing/08-typer-new/typer.ml +++ b/src/passes/09-typing/08-typer-new/typer.ml @@ -455,16 +455,20 @@ 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.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%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%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%bind assignment = trace_option (corner_case (Format.asprintf "can't find assignment for root %a" Var.pp root)) @@ (Map.find_opt root assignments) in @@ -472,11 +476,14 @@ 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 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 () = ignore env in (* TODO: shouldn't we use the `env` somewhere? *) ok (node, state) diff --git a/src/stages/2-ast_imperative/PP.ml b/src/stages/2-ast_imperative/PP.ml index 2853dd37e..0bb99ad44 100644 --- a/src/stages/2-ast_imperative/PP.ml +++ b/src/stages/2-ast_imperative/PP.ml @@ -71,7 +71,7 @@ let rec expression ppf (e : expression) = and expression_content ppf (ec : expression_content) = match ec with | E_literal l -> - literal ppf l + fprintf ppf "%a" literal l | E_variable n -> fprintf ppf "%a" expression_variable n | E_application {lamb;args} -> diff --git a/src/stages/5-ast_typed/ast_typed.ml b/src/stages/5-ast_typed/ast_typed.ml index 99f048844..561e3f694 100644 --- a/src/stages/5-ast_typed/ast_typed.ml +++ b/src/stages/5-ast_typed/ast_typed.ml @@ -17,5 +17,6 @@ module Helpers = Helpers include Types include Misc include Combinators +module Debug = Stage_common.Debug let program_environment env program = fst (Compute_environment.program env program) diff --git a/src/stages/common/ast_common.ml b/src/stages/common/ast_common.ml index 605fd90c8..43676422b 100644 --- a/src/stages/common/ast_common.ml +++ b/src/stages/common/ast_common.ml @@ -3,3 +3,4 @@ include Types module Types = Types module PP = PP module Helpers = Helpers +module Debug = Debug diff --git a/src/stages/common/debug.ml b/src/stages/common/debug.ml new file mode 100644 index 000000000..6e435e395 --- /dev/null +++ b/src/stages/common/debug.ml @@ -0,0 +1 @@ +let debug_new_typer = false diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index eb707b5f5..413613104 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -27,8 +27,10 @@ type type_variable = Ast_typed.type_variable type type_expression = Ast_typed.type_expression (* generate a new type variable and gave it an id *) -let fresh_type_variable : ?name:string -> unit -> type_variable = - Var.fresh +let fresh_type_variable : ?name:string -> unit -> type_variable = fun ?name () -> + let fresh_name = Var.fresh ?name () in + let () = (if Ast_typed.Debug.debug_new_typer && false then Printf.printf "Generated variable %s\n%!%s\n%!" (Var.debug fresh_name) (Printexc.get_backtrace ())) in + fresh_name let type_expression'_of_simple_c_constant : constant_tag * type_expression list -> Ast_typed.type_content option = fun (c, l) -> match c, l with diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 9ed64a53c..ca68a94b9 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -98,7 +98,9 @@ let typed_program_with_imperative_input_to_michelson let env = Ast_typed.program_environment Environment.default program in let%bind sugar = Compile.Of_imperative.compile_expression input in let%bind core = Compile.Of_sugar.compile_expression sugar in +let () = (if Ast_typed.Debug.debug_new_typer then Printf.printf "\nINPUT = %s\n\n%!" (Format.asprintf "%a" Ast_core.PP.expression core)) in let%bind app = Compile.Of_core.apply entry_point core in +let () = (if Ast_typed.Debug.debug_new_typer then Format.printf "\n\nSTATE IZ=%a\n\n" Typesystem.Solver_types.pp_typer_state state) in let%bind (typed_app,new_state) = Compile.Of_core.compile_expression ~env ~state app in let () = Typer.Solver.discard_state new_state in let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in diff --git a/vendors/ligo-utils/simple-utils/var.ml b/vendors/ligo-utils/simple-utils/var.ml index 490d3430f..8aa5b3b92 100644 --- a/vendors/ligo-utils/simple-utils/var.ml +++ b/vendors/ligo-utils/simple-utils/var.ml @@ -47,3 +47,5 @@ let fresh ?name () = let fresh_like v = fresh ~name:v.name () + +let debug v = match v.counter with Some c -> Printf.sprintf "%s(%d)" v.name c | None -> Printf.sprintf "%s(None)" v.name diff --git a/vendors/ligo-utils/simple-utils/var.mli b/vendors/ligo-utils/simple-utils/var.mli index 6d4936761..d81d69548 100644 --- a/vendors/ligo-utils/simple-utils/var.mli +++ b/vendors/ligo-utils/simple-utils/var.mli @@ -43,3 +43,5 @@ val fresh_like : 'a t -> 'b t (* Reset the global counter. Danger, do not use... Provided for tests only. *) val reset_counter : unit -> unit + +val debug : 'a t -> string From 1cc64d6812aa1dd30cce1b372f710e65756893e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 17 Jun 2020 23:18:58 +0100 Subject: [PATCH 04/10] reasons for failing tests --- src/test/integration_tests.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 022942e31..26bc9c6fc 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -2403,16 +2403,16 @@ let loop_bugs_ligo () : (unit, _) result = ok () let main = test_suite "Integration (End to End)" [ - test "bytes unpack" bytes_unpack ; - test "bytes unpack (mligo)" bytes_unpack_mligo ; - test "bytes unpack (religo)" bytes_unpack_religo ; - test "key hash" key_hash ; - test "key hash (mligo)" key_hash_mligo ; - test "key hash (religo)" key_hash_religo ; - test "check signature" check_signature ; - test "check signature (mligo)" check_signature_mligo ; - test "check signature (religo)" check_signature_religo ; - test "chain id" chain_id ; + test "chain id" chain_id ; (* record *) + test "bytes unpack" bytes_unpack ; (* record *) + test "bytes unpack (mligo)" bytes_unpack_mligo ; (* record *) + test "bytes unpack (religo)" bytes_unpack_religo ; (* record *) + test "key hash" key_hash ; (* C_access_label *) + test "key hash (mligo)" key_hash_mligo ; (* C_access_label *) + test "key hash (religo)" key_hash_religo ; (* C_access_label *) + test "check signature" check_signature ; (* C_access_label *) + test "check signature (mligo)" check_signature_mligo ; (* C_access_label *) + test "check signature (religo)" check_signature_religo ; (* C_access_label *) test "type alias" type_alias ; test "function" function_ ; test "blockless function" blockless; 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 05/10] 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 From 942000065b4a34b9cc5f24e15d32043e00809791 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 19 Jun 2020 03:45:25 +0100 Subject: [PATCH 06/10] Weakly-typed creation of ADT elements --- src/stages/5-ast_typed/PP_generic.ml | 4 +- src/stages/5-ast_typed/PP_json.ml | 8 +- src/stages/5-ast_typed/compare_generic.ml | 4 +- src/stages/5-ast_typed/types_utils.ml | 30 ++++++ src/stages/adt_generator/common.ml | 4 + src/stages/adt_generator/dune | 1 + src/stages/adt_generator/generator.raku | 116 +++++++++++++++++----- src/stages/adt_generator/generic.ml | 48 ++++++--- src/test/adt_generator/amodule_utils.ml | 7 ++ src/test/adt_generator/use_a_fold.ml | 89 ++++++++++++----- vendors/Red-Black_Trees/PolyMap.ml | 19 ++++ vendors/Red-Black_Trees/PolyMap.mli | 25 +++++ vendors/Red-Black_Trees/PolySet.ml | 2 + vendors/Red-Black_Trees/PolySet.mli | 8 +- vendors/UnionFind/Poly2.ml | 2 + vendors/UnionFind/Poly2.mli | 5 + 16 files changed, 296 insertions(+), 76 deletions(-) diff --git a/src/stages/5-ast_typed/PP_generic.ml b/src/stages/5-ast_typed/PP_generic.ml index c29a31b30..662d41cc6 100644 --- a/src/stages/5-ast_typed/PP_generic.ml +++ b/src/stages/5-ast_typed/PP_generic.ml @@ -42,10 +42,10 @@ module M = struct let op ppf : (no_state, unit) fold_config = { generic = (fun NoState info -> match info.node_instance.instance_kind with - | RecordInstance { fields } -> + | RecordInstance { field_instances } -> let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) = fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in - fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields + fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) field_instances | VariantInstance { constructor ; _ } -> if constructor.cf_new_fold needs_parens NoState then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState diff --git a/src/stages/5-ast_typed/PP_json.ml b/src/stages/5-ast_typed/PP_json.ml index d700c65b3..18c6b8baf 100644 --- a/src/stages/5-ast_typed/PP_json.ml +++ b/src/stages/5-ast_typed/PP_json.ml @@ -10,12 +10,12 @@ module M = struct let to_json : (no_state, json) fold_config = { generic = (fun NoState info -> match info.node_instance.instance_kind with - | RecordInstance { fields } -> - let fields' = List.fold_left + | RecordInstance { field_instances } -> + let field_instances' = List.fold_left (fun acc (fld : ('xi, json) Adt_info.ctor_or_field_instance) -> (fld.cf.name, fld.cf_continue NoState)::acc) - [] fields + [] field_instances in - `Assoc fields' + `Assoc field_instances' | VariantInstance { constructor ; _ } -> `List [ `String constructor.cf.name ; constructor.cf_continue NoState ] | PolyInstance { poly=_; arguments=_; poly_continue } -> diff --git a/src/stages/5-ast_typed/compare_generic.ml b/src/stages/5-ast_typed/compare_generic.ml index e630f1e3a..a1be2e6ed 100644 --- a/src/stages/5-ast_typed/compare_generic.ml +++ b/src/stages/5-ast_typed/compare_generic.ml @@ -36,10 +36,10 @@ module M = struct let op : (no_state, t) fold_config = { generic = (fun NoState info -> match info.node_instance.instance_kind with - | RecordInstance { fields } -> + | RecordInstance { field_instances } -> let aux (fld : ('xi, 'xo) Adt_info.ctor_or_field_instance) = ( fld.cf.name , fun () -> fld.cf_continue NoState ) in - Record ("name_of_the_record", List.map aux fields) + Record ("name_of_the_record", List.map aux field_instances) | VariantInstance { constructor ; _ } -> VariantConstructor ("name_of_the_variant", constructor.cf.name, fun () -> constructor.cf_continue NoState) | PolyInstance { poly=_; arguments=_; poly_continue } -> diff --git a/src/stages/5-ast_typed/types_utils.ml b/src/stages/5-ast_typed/types_utils.ml index 134b990f4..1e3361d3b 100644 --- a/src/stages/5-ast_typed/types_utils.ml +++ b/src/stages/5-ast_typed/types_utils.ml @@ -127,3 +127,33 @@ let fold_map__poly_set : type a state new_a err . new_a extra_info__comparable - ok (state , PolySet.add new_elt s) in let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in ok (state , m) + + +(* This takes a fold_map__xxx function and turns it into a make__xxx + function. + It just swaps the error monad with the option monad, and uses unit + as the type for the state and for "errors". *) +let fold_map_to_make fold_map = fun f v -> + match fold_map (fun () x -> match f x with Some x' -> ok ((), x') | None -> Pervasives.Error ()) () v with + Pervasives.Ok (((), v'), _) -> Some v' + | Pervasives.Error () -> None + +(* This can't be done automatically, because the auto-generated + comparison functions make use of the fold, the fold supplies to + users some "make" functions, and there's no deterministic way to + extract the comparison functions (or other typeclass-like + functions). + + Instead of writing the following functions, we could just write the + get_typeclass_compare functions for poly_unionfind and poly_set, + but the resulting code wouldn't be much clearer. *) +let make__constructor_map f v = fold_map_to_make fold_map__constructor_map f v +let make__label_map f v = fold_map_to_make fold_map__label_map f v +let make__list f v = fold_map_to_make fold_map__list f v +let make__location_wrap f v = fold_map_to_make fold_map__location_wrap f v +let make__list_ne f v = fold_map_to_make fold_map__list_ne f v +let make__option f v = fold_map_to_make fold_map__option f v +let make__poly_unionfind f v = fold_map_to_make (fold_map__poly_unionfind { compare = failwith "TODO" (*UnionFind.Poly2.get_compare v*) }) f v +let make__PolyMap f v = fold_map_to_make fold_map__PolyMap f v +let make__typeVariableMap f v = fold_map_to_make fold_map__typeVariableMap f v +let make__poly_set f v = fold_map_to_make (fold_map__poly_set { compare = failwith "TODO" (*PolySet.get_compare v*) }) f v diff --git a/src/stages/adt_generator/common.ml b/src/stages/adt_generator/common.ml index 6c6d2e650..4e9822bdb 100644 --- a/src/stages/adt_generator/common.ml +++ b/src/stages/adt_generator/common.ml @@ -1,3 +1,7 @@ type ('a,'err) monad = ('a,'err) Simple_utils.Trace.result;; let (>>?) v f = Simple_utils.Trace.bind f v;; let return v = Simple_utils.Trace.ok v;; + +let sorted_bindings m = + List.sort (fun (a , _) (b , _) -> String.compare a b) + @@ RedBlackTrees.PolyMap.bindings m diff --git a/src/stages/adt_generator/dune b/src/stages/adt_generator/dune index 5e98e3845..a0e5e6ff9 100644 --- a/src/stages/adt_generator/dune +++ b/src/stages/adt_generator/dune @@ -3,5 +3,6 @@ (public_name ligo.adt_generator) (libraries simple-utils + RedBlackTrees ) ) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index aa5de686b..0cfbf300a 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -94,6 +94,12 @@ $*OUT = open $folder_filename, :w; for $statements -> $statement { say "$statement" } say "open $moduleName;;"; + say " (* must be provided by one of the open or include statements: *)"; + say " module CheckFolderInputSignature = struct"; + for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly + { say " let make__$poly : type a b . (a -> b option) -> a $poly -> b $poly option = make__$poly;;"; } + say " end"; + say ""; say " include Adt_generator.Generic.BlahBluh"; say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{"; @@ -107,9 +113,25 @@ $*OUT = open $folder_filename, :w; { say " $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_state;"; } say ' };;'; + say ""; + say " type whatever ="; + say " | NoArgument (* supplied to make constructors with no arguments *)"; + # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') + for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin + { say " | Whatever_{tc $builtin} of $builtin"; } + for $adts.list -> $t + { say " | Whatever_{tc $t} of $t" } + + say " type make_poly ="; + # look for built-in polymorphic types + for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly + { say " | Make_{tc $poly} of (whatever $poly -> whatever option)"; } + say ""; say " module Adt_info = Adt_generator.Generic.Adt_info (struct"; say " type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config;;"; + say " type nonrec whatever = whatever;;"; + say " type nonrec make_poly = make_poly;;"; say " end);;"; say " include Adt_info;;"; say " type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_state) Adt_info.node_instance_info) _fold_config;;"; @@ -127,14 +149,31 @@ $*OUT = open $folder_filename, :w; for $adts.list -> $t { for $t.list -> $c { say " (* info for field or ctor $t.$c *)"; - say " let info__$t__$c : Adt_info.ctor_or_field = \{"; - say " name = \"$c\";"; - say " is_builtin = {$c ?? 'true' !! 'false'};"; - say " type_ = \"$c\";"; - say ' };;'; + if ($t eq $variant) { + say " let info__$t__$c : Adt_info.constructor_type = \{"; + say " ctor = \{"; + say " name = \"$c\";"; + say " is_builtin = {$c ?? 'true' !! 'false'};"; + say " type_ = \"$c\";"; + say " \};"; + if ($c eq '') { + # this constructor has no arguments. + say " make_ctor = (function NoArgument -> Some (Whatever_{tc $t} $c) | _ -> None);"; + } else { + say " make_ctor = (function Whatever_{tc $c} v -> Some (Whatever_{tc $t} ($c v)) | _ -> None);"; + } + say ' };;'; + } else { + say " let info__$t__$c : Adt_info.ctor_or_field = \{"; + say " name = \"$c\";"; + say " is_builtin = {$c ?? 'true' !! 'false'};"; + say " type_ = \"$c\";"; + say ' };;'; + } # say ""; say " let continue_info__$t__$c : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c || 'unit'} -> (in_qstate, out_qstate) Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{"; - say " cf = info__$t__$c;"; + my $dotctor = ($t eq $variant) ?? ".ctor" !! ""; # TODO: give the full constructor info with its "make" function instead of extracting the .ctor part. + say " cf = info__$t__$c$dotctor;"; say " cf_continue = (fun state -> the_folds.fold__$t__$c the_folds visitor state x);"; say " cf_new_fold = (fun visitor state -> the_folds.fold__$t__$c the_folds visitor state x);"; say ' };;'; @@ -142,16 +181,40 @@ $*OUT = open $folder_filename, :w; } say " (* info for node $t *)"; say " let info__$t : Adt_info.node = \{"; - my $kind = do given $t { - when $record { "Record" } - when $variant { "Variant" } - default { "Poly \"$_\"" } + print " kind = "; + do given $t { + when $record { + say "RecordType \{"; + say " fields = ["; + for $t.list -> $f { + say " info__$t__$f;"; + } + say " ];"; + say " make_record = (fun r -> match Adt_generator.Common.sorted_bindings r with"; + say " | ["; + for $t.list.sort({$_}) -> $f { + say " (\"$f\" , Whatever_{tc $f} $f) ;"; + } + say " ] -> Some (Whatever_{tc $t} \{"; + for $t.list -> $f { say " $f ;"; } + say " \})"; + say " | _ -> None)"; + say " \};"; } + when $variant { + say "VariantType \{"; + print " constructors = [ "; + for $t.list -> $c { print "info__$t__$c ; "; } + say "];"; + say " \};"; } + default { + say "PolyType \{"; + say " poly_name = \"$_\";"; + print " make_poly = Make_{tc $_} (fun p -> match make__$_ "; + for $t.list -> $a { print "(function Whatever_{tc $a} v -> Some v | _ -> None)"; } + say " p with Some p -> Some (Whatever_{tc $t} p) | None -> None);"; + say " \};"; } }; - say " kind = $kind;"; say " declaration_name = \"$t\";"; - print " ctors_or_fields = [ "; - for $t.list -> $c { print "info__$t__$c ; "; } - say "];"; say ' };;'; # say ""; # TODO: factor out some of the common bits here. @@ -161,10 +224,10 @@ $*OUT = open $folder_filename, :w; do given $t { when $record { say ' instance_kind = RecordInstance {'; - print " fields = [ "; + print " field_instances = [ "; for $t.list -> $c { print "continue_info__$t__$c the_folds visitor x.$c ; "; } - say " ];"; - say ' };'; + say "];"; + say ' };'; } when $variant { say " instance_kind ="; @@ -174,7 +237,7 @@ $*OUT = open $folder_filename, :w; for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c the_folds visitor { $c ?? 'v' !! '()' }"; } say " );"; print " variant = [ "; - for $t.list -> $c { print "info__$t__$c ; "; } + for $t.list -> $c { print "info__$t__$c.ctor ; "; } # TODO: give the full constructor info with its "make" function. say "];"; say ' };'; } @@ -183,9 +246,7 @@ $*OUT = open $folder_filename, :w; say ' PolyInstance {'; say " poly = \"$_\";"; print " arguments = ["; - # TODO: sort by c (currently we only have one-argument - # polymorphic types so it happens to work but should be fixed. - for $t.list -> $c { print "\"$c\""; } + for $t.list.sort({$_}) -> $c { print "\"$c\""; } say "];"; print " poly_continue = (fun state -> visitor.$_ visitor ("; print $t @@ -201,10 +262,11 @@ $*OUT = open $folder_filename, :w; say ""; say " (* info for adt $moduleName *)"; - print " let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; + say " let whole_adt_info : unit -> Adt_info.adt = fun () ->"; + print " match RedBlackTrees.PolyMap.from_list ~cmp:String.compare [ "; for $adts.list -> $t - { print "info__$t ; "; } - say "];;"; + { print "\"$t\" , info__$t ; "; } + say "] with Some x -> x | None -> failwith \"Internal error: duplicate nodes in ADT info\";;"; # fold functions say ""; @@ -300,7 +362,7 @@ $*OUT = open $mapper_filename, :w; } say ""; - for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t + for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_}), :with(&[eqv])) -> $t { my $ty = $t[0]; my $typeclass = $typeclasses{$t}; say " val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; } @@ -311,7 +373,7 @@ $*OUT = open $mapper_filename, :w; say " module O : OSig = $oModuleName"; say ""; say " (* must be provided by one of the open or include statements: *)"; - say " module CheckInputSignature = struct"; + say " module CheckMapperInputSignature = struct"; for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly { say " let fold_map__$poly : type a new_a state err .{ $typeclasses{$poly} ?? " new_a extra_info__{$typeclasses{$poly}} ->" !! "" } (state -> a -> (state * new_a, err) monad) -> state -> a $poly -> (state * new_a $poly , err) monad = fold_map__$poly;;"; } say " end"; @@ -500,7 +562,7 @@ $*OUT = open $combinators_filename, :w; } say ""; - for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t + for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_}), :with(&[eqv])) -> $t { my $ty = $t[0]; my $typeclass = $typeclasses{$t}; say "let extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass = {tc $typeclass}.$ty;;"; diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml index f1ad0fcb8..666054e8c 100644 --- a/src/stages/adt_generator/generic.ml +++ b/src/stages/adt_generator/generic.ml @@ -10,14 +10,35 @@ module BlahBluh = struct type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;; end -module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct +module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config;; type whatever;; type make_poly;; end) = struct type kind = - | Record - | Variant - | Poly of string + | RecordType of record_type + | VariantType of variant_type + | PolyType of poly_type - type ('in_state , 'out_state) record_instance = { - fields : ('in_state , 'out_state) ctor_or_field_instance list; + and ctor_or_field = + { + name : string; + is_builtin : bool; + type_ : string; + } + + and record_type = { + fields : ctor_or_field list; + make_record : (string , M.whatever) RedBlackTrees.PolyMap.t -> M.whatever option + } + + and ('in_state , 'out_state) record_instance = { + field_instances : ('in_state , 'out_state) ctor_or_field_instance list; + } + + and variant_type = { + constructors : constructor_type list; + } + + and constructor_type = { + ctor : ctor_or_field; + make_ctor : M.whatever -> M.whatever option; } and ('in_state , 'out_state) constructor_instance = { @@ -25,6 +46,11 @@ module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_ variant : ctor_or_field list } + and poly_type = { + poly_name : string; + make_poly : M.make_poly; + } + and ('in_state , 'out_state) poly_instance = { poly : string; arguments : string list; @@ -41,13 +67,6 @@ module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_ instance_kind : ('in_state , 'out_state) kind_instance; } - and ctor_or_field = - { - name : string; - is_builtin : bool; - type_ : string; - } - and ('in_state , 'out_state) ctor_or_field_instance = { cf : ctor_or_field; @@ -59,11 +78,10 @@ module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_ { kind : kind; declaration_name : string; - ctors_or_fields : ctor_or_field list; } (* TODO: rename things a bit in this file. *) - and adt = node list + and adt = (string, node) RedBlackTrees.PolyMap.t and ('in_state , 'out_state) node_instance_info = { adt : adt ; node_instance : ('in_state , 'out_state) instance ; diff --git a/src/test/adt_generator/amodule_utils.ml b/src/test/adt_generator/amodule_utils.ml index 6befe8167..78ed43368 100644 --- a/src/test/adt_generator/amodule_utils.ml +++ b/src/test/adt_generator/amodule_utils.ml @@ -12,3 +12,10 @@ let fold_map__option continue state v = match v with Some x -> continue state x | None -> ok None + +let make__list f l = + List.fold_right + (fun elt acc -> match acc, f elt with + Some acc, Some x -> Some (x :: acc) + | _ -> None) + l (Some []) diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index f7fec8c15..1de7e353a 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -61,34 +61,75 @@ let _noi : (int, _) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) let _nob : (bool, _) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) type no_state = NoState +let to_string some_root = + let op : ('i, 'o) Generated_fold.fold_config = { + generic = (fun NoState info -> + match info.node_instance.instance_kind with + | RecordInstance { field_instances } -> + false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) field_instances) ^ " }" + | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_; }; cf_continue; cf_new_fold=_ }; variant=_ } -> + (match cf_continue NoState with + | true, arg -> true, name ^ " (" ^ arg ^ ")" + | false, arg -> true, name ^ " " ^ arg) + | PolyInstance { poly=_; arguments=_; poly_continue } -> + (poly_continue NoState) + ) ; + generic_empty_ctor = (fun NoState -> false, "") ; + string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ; + unit = (fun _visitor NoState () -> false , "()") ; + int = (fun _visitor NoState i -> false , string_of_int i) ; + list = (fun _visitor continue NoState lst -> + false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ; + (* generic_ctor_or_field = (fun _info state -> + * match _info () with + * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" + * ); *) + } in + let (_ , state) = Generated_fold.fold__root op NoState some_root in + state + let () = let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in - let op : ('i, 'o) Generated_fold.fold_config = { - generic = (fun NoState info -> - match info.node_instance.instance_kind with - | RecordInstance { fields } -> - false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }" - | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } -> - (match cf_continue NoState with - | true, arg -> true, name ^ " (" ^ arg ^ ")" - | false, arg -> true, name ^ " " ^ arg) - | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue NoState) - ) ; - generic_empty_ctor = (fun NoState -> false, "") ; - string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ; - unit = (fun _visitor NoState () -> false , "()") ; - int = (fun _visitor NoState i -> false , string_of_int i) ; - list = (fun _visitor continue NoState lst -> - false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ; - (* generic_ctor_or_field = (fun _info state -> - * match _info () with - * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" - * ); *) - } in - let (_ , state) = Generated_fold.fold__root op NoState some_root in let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in + let state = to_string some_root in if String.equal state expected; then () else failwith (Printf.sprintf "Test failed: expected\n %s\n but got\n %s" expected state) + +(* Test generic creation of nodes *) +let () = + let i = whole_adt_info () in + let dynamic = + match RedBlackTrees.PolyMap.find_opt "rootB" i with + | Some { kind = PolyType { poly_name = _; make_poly }; declaration_name = _ } -> + (match make_poly with + Make_List mk -> + match mk [ Whatever_Int 42 ; Whatever_Int 43 ] with + Some l -> + (match RedBlackTrees.PolyMap.find_opt "root" i with + Some { kind = VariantType { constructors }; declaration_name = _ } -> + (* TODO: use a PolyMap.t *) + let { ctor = _ ; make_ctor } = List.find (fun { ctor = { name; is_builtin = _; type_ = _ }; make_ctor = _ } -> String.equal name "B") constructors in + let _ = + (match l with + | Whatever_RootB _ -> () | _ -> failwith "whoops") + in + (match make_ctor l with (* Wrap the int list with the B constructor *) + Some b -> b + | None -> failwith "Couldn't create instance of the B constructor, did you supply the right argument type?") + | Some { kind = _ ; _ } -> failwith "unexpected node info for root: wrong kind !!!" + | None -> failwith "can't find node info for root !!!") + | None -> failwith "Couldn't create list, did you supply the wrong element type?" + (* | _ -> failwith "unexpected maker function for rootB: expected rootB to be a list !!!" *) + ) + | Some { kind = _ ; _ } -> failwith "unexpected node info for rootB: wrong kind !!!" + | None -> failwith "can't find node info for rootB !!!" + in + (match dynamic with + Whatever_Root root -> + (match root with + B [ 42 ; 43 ] -> () (* Victory, we created the expected value *) + | _ -> failwith ("Incorrect value " ^ to_string root)) + | _ -> failwith "Incorrect result type: expected a dynamically-typed root, but got something else") + diff --git a/vendors/Red-Black_Trees/PolyMap.ml b/vendors/Red-Black_Trees/PolyMap.ml index 0ed6e9d6d..fee49b019 100644 --- a/vendors/Red-Black_Trees/PolyMap.ml +++ b/vendors/Red-Black_Trees/PolyMap.ml @@ -31,11 +31,30 @@ let find key map = let find_opt key map = try Some (find key map) with Not_found -> None +let has_key key map = + match find_opt key map with + Some _ -> true + | None -> false + let update key updater map = match updater (find_opt key map) with | None -> remove key map | Some v -> add key v map +type ('key, 'value) added = {map : ('key, 'value) t; duplicates : ('key * 'value) list; added : ('key * 'value) list} +let add_list elts map = + let aux = fun {map ; duplicates ; added} ((key, value) as kv) -> + if has_key key map + then {map; duplicates = kv :: duplicates ; added} + else {map = add key value map; duplicates; added = kv :: added} in + List.fold_left aux {map; duplicates=[]; added = []} elts + +let from_list ~cmp elts = + match add_list elts (create ~cmp) with + { map; duplicates = []; added = _ } -> Some map + | _ -> None (* Refuse to create a map from a list with duplicates *) + + let bindings map = RB.fold_dec (fun ~elt ~acc -> elt::acc) ~init:[] map.tree diff --git a/vendors/Red-Black_Trees/PolyMap.mli b/vendors/Red-Black_Trees/PolyMap.mli index bff0e87ce..34f6b6948 100644 --- a/vendors/Red-Black_Trees/PolyMap.mli +++ b/vendors/Red-Black_Trees/PolyMap.mli @@ -20,6 +20,13 @@ type ('key, 'value) map = ('key, 'value) t val create : cmp:('key -> 'key -> int) -> ('key, 'value) t +(* The value of the call [from_list ~cmp elts] is a [Some map] with + [cmp] being the comparison over the keys. The map initially + contains the bindings listed in [elts]. If the same (w.r.t. [cmp]) + key occurs twice [elts] then [None] is returned instead to indicate + the error. *) +val from_list : cmp:('key -> 'key -> int) -> ('key * 'value) list -> ('key, 'value) t option + val empty : ('key, 'value) t -> ('key, 'new_value) t (* Emptiness *) @@ -50,6 +57,12 @@ val find : 'key -> ('key, 'value) t -> 'value val find_opt : 'key -> ('key, 'value) t -> 'value option +(* The value of the call [find_opt key map] is [true] if the key + [key] is bound to some value in the map [map], and [None] + otherwise. *) + +val has_key : 'key -> ('key, 'value) t -> bool + (* The value of the call [update key f map] is a map containing all the bindings of the map [map], extended by the binding of [key] to the value returned by [f], when [f maybe_value] returns @@ -66,6 +79,18 @@ val update : 'key -> ('value option -> 'value option) -> ('key, 'value) map -> ( (with respect to the total comparison function used to create the map). *) +(* The value of the call [add_list kv_list map] is a record of type + [('key, 'value) added]. The elements from the [kv_list] are added + to the [map] starting from the head of the list. The elements for + which the key is already present in the [map] at the point at which + they are added are gathered in the [duplicates] list (and the [map] + is not updated for these elements, i.e. it keeps the pre-existing + version of the value associated to that key). The elements for + which the key is not already present in the [map] are added to the + [map], and gathered in the [added] list. *) +type ('key, 'value) added = {map : ('key, 'value) t; duplicates : ('key * 'value) list; added : ('key * 'value) list} +val add_list : ('key * 'value) list -> ('key, 'value) t -> ('key, 'value) added + val bindings : ('key, 'value) t -> ('key * 'value) list (* The side-effect of evaluating the call [iter f map] is the diff --git a/vendors/Red-Black_Trees/PolySet.ml b/vendors/Red-Black_Trees/PolySet.ml index 1dc3c12b0..fe24649d7 100644 --- a/vendors/Red-Black_Trees/PolySet.ml +++ b/vendors/Red-Black_Trees/PolySet.ml @@ -36,6 +36,8 @@ let add_list elts set = let elements set = RB.elements set.tree +let get_compare set = set.cmp + let iter f set = RB.iter f set.tree let fold_inc f set = RB.fold_inc (fun ~elt -> f elt) set.tree diff --git a/vendors/Red-Black_Trees/PolySet.mli b/vendors/Red-Black_Trees/PolySet.mli index 589a1374b..e9e85c3be 100644 --- a/vendors/Red-Black_Trees/PolySet.mli +++ b/vendors/Red-Black_Trees/PolySet.mli @@ -63,13 +63,17 @@ val mem : 'elt -> 'elt t -> bool are already part of the [set] at the point at which they are added are gathered in the [duplicates] list (and the [set] is not updated for these elements, i.e. it keeps the pre-existing version of the - element). The elements which are not already members of the set are - added to the [set], and gathered in the [added] list. *) + element). The elements which are not already members of the [set] + are added to the [set], and gathered in the [added] list. *) type 'a added = {set : 'a set; duplicates : 'a list; added : 'a list} val add_list : 'a list -> 'a set -> 'a added val elements : 'elt t -> 'elt list +(* The value of the call [get_compare set] is the comparison function + used by the given set *) +val get_compare : 'elt t -> ('elt -> 'elt -> int) + (* The side-effect of evaluating the call [iter f set] is the successive side-effects of the calls [f elt], for all the elements [elt] of the set [set], sorted in increasing order (with respect to diff --git a/vendors/UnionFind/Poly2.ml b/vendors/UnionFind/Poly2.ml index f3ac7fd8c..a73236db2 100644 --- a/vendors/UnionFind/Poly2.ml +++ b/vendors/UnionFind/Poly2.ml @@ -145,6 +145,8 @@ let partitions : 'item . 'item partition -> 'item list list = let partitions = List.sort (compare_lists_by_first compare) partitions in partitions +let get_compare p = p.compare + (** {1 Printing} *) let print ppf (p: 'item partition) = diff --git a/vendors/UnionFind/Poly2.mli b/vendors/UnionFind/Poly2.mli index 8cea54c0c..a37129c64 100644 --- a/vendors/UnionFind/Poly2.mli +++ b/vendors/UnionFind/Poly2.mli @@ -54,6 +54,11 @@ val elements : 'item partition -> 'item list have the same order). *) val partitions : 'item partition -> 'item list list +(** The value of the call [get_compare p] is the comparison function + used by p *) +val get_compare : 'item partition -> ('item -> 'item -> int) + + (** The call [print p] is a value of type [Buffer.t] containing strings denoting the partition [p], based on [Ord.to_string]. *) From a4e414bd76d7861bfa9b2fafe0af5bb7a1f2b693 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 24 Jun 2020 10:37:57 +0100 Subject: [PATCH 07/10] Temporarily disable webide stage, because it contains a randomly failing test. --- .gitlab-ci.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 39c87f000..03974edcc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -85,9 +85,11 @@ xrefcheck: .webide-e2e: extends: .nix only: - - merge_requests - - dev - - /^.*-run-dev$/ + # Disabled for now unless the branch name contains webide, because a test in this job fails randomly + - /.*webide.*/ + #- merge_requests + #- dev + #- /^.*-run-dev$/ script: - nix-build nix -A ligo-editor.e2e From 351018f8d2b4b40261783e434998e033119bec45 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 22 Jun 2020 15:26:47 +0200 Subject: [PATCH 08/10] errors for compare in the new typer --- .../09-typing/08-typer-common/errors.ml | 296 +++++++++++++++++- src/passes/09-typing/08-typer-new/compare.ml | 165 ++++++++++ src/passes/09-typing/08-typer-new/typer.ml | 7 +- vendors/ligo-utils/simple-utils/trace.ml | 3 + 4 files changed, 466 insertions(+), 5 deletions(-) create mode 100644 src/passes/09-typing/08-typer-new/compare.ml diff --git a/src/passes/09-typing/08-typer-common/errors.ml b/src/passes/09-typing/08-typer-common/errors.ml index b2a6bdf13..4e09f3285 100644 --- a/src/passes/09-typing/08-typer-common/errors.ml +++ b/src/passes/09-typing/08-typer-common/errors.ml @@ -1,6 +1,7 @@ open Trace open Simple_utils.Display + let stage = "typer" type typer_error = [ @@ -69,7 +70,28 @@ type typer_error = [ | `Typer_constant_decl_tracer of Ast_core.expression_variable * Ast_core.expr * Ast_typed.type_expression option * typer_error | `Typer_match_variant_tracer of Ast_core.matching_expr * typer_error | `Typer_unrecognized_type_operator of Ast_core.type_expression - |`Typer_expected_ascription of Ast_core.expression + | `Typer_expected_ascription of Ast_core.expression + | `Typer_different_kinds of Ast_typed.type_expression * Ast_typed.type_expression + | `Typer_different_constants of Ast_typed.type_constant * Ast_typed.type_constant + | `Typer_different_operators of Ast_typed.type_operator * Ast_typed.type_operator + | `Typer_operator_number_of_arguments of Ast_typed.type_operator * Ast_typed.type_operator * int * int + | `Typer_different_record_props of + Ast_typed.type_expression * Ast_typed.type_expression * Ast_typed.te_lmap * Ast_typed.te_lmap * string * string + | `Typer_different_kind_record_tuple of + Ast_typed.type_expression * Ast_typed.type_expression * Ast_typed.te_lmap * Ast_typed.te_lmap + | `Typer_different_size_records_tuples of + Ast_typed.type_expression * Ast_typed.type_expression * Ast_typed.te_lmap * Ast_typed.te_lmap + | `Typer_different_size_sums of + Ast_typed.type_expression * Ast_typed.type_expression + | `Typer_different_types of string * Ast_typed.type_expression * Ast_typed.type_expression * typer_error + | `Typer_different_literals of string * Ast_typed.literal * Ast_typed.literal + | `Typer_different_values of string * Ast_typed.expression * Ast_typed.expression + | `Typer_different_literals_because_different_types of string * Ast_typed.literal * Ast_typed.literal + | `Typer_different_values_because_different_types of string * Ast_typed.expression * Ast_typed.expression + | `Typer_uncomparable_literals of string * Ast_typed.literal * Ast_typed.literal + | `Typer_uncomparable_values of string * Ast_typed.expression * Ast_typed.expression + | `Typer_missing_key_in_record_value of string + | `Typer_compare_tracer of typer_error ] let michelson_comb_no_record (loc:Location.t) = `Typer_michelson_comb_no_record loc @@ -150,6 +172,23 @@ let constant_declaration_tracer (name: Ast_core.expression_variable) (ae:Ast_cor `Typer_constant_decl_tracer (name,ae,expected,err) let in_match_variant_tracer (ae:Ast_core.matching_expr) (err:typer_error) = `Typer_match_variant_tracer (ae,err) +let different_kinds a b = `Typer_different_kinds (a,b) +let different_constants a b = `Typer_different_constants (a,b) +let different_operators a b = `Typer_different_operators (a,b) +let different_operator_number_of_arguments opa opb lena lenb = `Typer_operator_number_of_arguments (opa, opb, lena, lenb) +let different_props_in_record a b ra rb ka kb = `Typer_different_record_props (a,b,ra,rb,ka,kb) +let different_kind_record_tuple a b ra rb = `Typer_different_kind_record_tuple (a,b,ra,rb) +let different_size_records_tuples a b ra rb = `Typer_different_size_records_tuples (a,b,ra,rb) +let different_size_sums a b = `Typer_different_size_sums (a,b) +let different_types name a b err = `Typer_different_types (name,a,b,err) +let different_literals name a b = `Typer_different_literals (name,a,b) +let different_values name a b = `Typer_different_values (name,a,b) +let different_literals_because_different_types name a b = `Typer_different_literals_because_different_types (name,a,b) +let different_values_because_different_types name a b = `Typer_different_values_because_different_types (name,a,b) +let error_uncomparable_literals name a b = `Typer_uncomparable_literals (name,a,b) +let error_uncomparable_values name a b = `Typer_uncomparable_values (name,a,b) +let missing_key_in_record_value k = `Typer_missing_key_in_record_value k +let compare_tracer err = `Typer_compare_tracer err let rec error_ppformat : display_format:string display_format -> Format.formatter -> typer_error -> unit = @@ -470,6 +509,75 @@ let rec error_ppformat : display_format:string display_format -> "@[%a@ expected ascription but got %a@]" Location.pp t.location Ast_core.PP.expression t + | `Typer_different_kinds (a,b) -> + Format.fprintf f + "@[ different kinds %a@ %a@]" + Ast_typed.PP.type_expression a + Ast_typed.PP.type_expression b + | `Typer_different_constants (a,b) -> + Format.fprintf f + "@[ different type constructors.@ \ + Expected these two constant type constructors to be the same, but they're different@ %a@ %a@]" + Ast_typed.PP.type_constant a + Ast_typed.PP.type_constant b + | `Typer_different_operators (a,b) -> + Format.fprintf f + "@[ different type constructors.@ \ + Expected these two n-ary type constructors to be the same, but they're different@ %a@ %a@]" + (Ast_typed.PP.type_operator Ast_typed.PP.type_expression) a + (Ast_typed.PP.type_operator Ast_typed.PP.type_expression) b + | `Typer_operator_number_of_arguments (opa, _opb, lena, lenb) -> + Format.fprintf f + "@[ different number of arguments to type constructors.@ \ + Expected these two n-ary type constructors to be the same, but they have different number\ + of arguments (both use the %s type constructor, but they have %d and %d arguments, respectively)@]" + (Ast_typed.Helpers.type_operator_name opa) lena lenb + | `Typer_different_record_props (_a,_b,ra,rb,_ka,_kb) -> + let names = if Ast_typed.Helpers.is_tuple_lmap ra &&Ast_typed.Helpers.is_tuple_lmap rb + then "tuples" else "records" in + Format.fprintf f + "@[ different keys in %s@]" + names + | `Typer_different_kind_record_tuple (_a,_b,ra,rb) -> + let name_a = if Ast_typed.Helpers.is_tuple_lmap ra then "tuple" else "record" in + let name_b = if Ast_typed.Helpers.is_tuple_lmap rb then "tuple" else "record" in + Format.fprintf f + "@[ different keys.@ Expected these two types to be the same, but they're different (one is a %s\ + and the other is a %s)@]" + name_a name_b + | `Typer_different_size_records_tuples (_a,_b,ra,rb) -> + let n = if Ast_typed.Helpers.is_tuple_lmap ra && Ast_typed.Helpers.is_tuple_lmap rb + then "tuples" else "records" in + Format.fprintf f + "@[ %s have different sizes.@ Expected these two types to be the same, but they're \ + different (both are %s, but with a different number of arguments)@]" + n n + | `Typer_different_size_sums (_a,_b) -> + Format.fprintf f + "@[ sum types have different sizes.@ Expected these two types to be the same, but they're \ + different" + | `Typer_different_types (name,_a,_b,err) -> + Format.fprintf f + "@[ %s are different.\ + Expected these two types to be the same, but they're different.@ %a@]" + name + (error_ppformat ~display_format) err + | `Typer_different_literals (name,_a,_b) -> + Format.fprintf f "@[ %s are different@]" name + | `Typer_different_values (name,_a,_b) -> + Format.fprintf f "@[ %s are different@]" name + | `Typer_different_literals_because_different_types (name,_a,_b) -> + Format.fprintf f "@[ Literals have different types: %s@]" name + | `Typer_different_values_because_different_types (name,_a,_b) -> + Format.fprintf f "@[ Values have different types: %s@]" name + | `Typer_uncomparable_literals (name,_a,_b) -> + Format.fprintf f "@[ %s are not comparable @]" name + | `Typer_uncomparable_values (name,_a,_b) -> + Format.fprintf f "@[ %s are not comparable @]" name + | `Typer_missing_key_in_record_value k -> + Format.fprintf f "@[ missing %s in one of the record @]" k + | `Typer_compare_tracer err -> + error_ppformat ~display_format f err ) let rec error_jsonformat : typer_error -> J.t = fun a -> @@ -1150,4 +1258,190 @@ let rec error_jsonformat : typer_error -> J.t = fun a -> ("location", location) ; ("value", value) ; ] in + json_error ~stage ~content + | `Typer_different_kinds (a,b) -> + let message = `String "different kinds" in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_constants (a,b) -> + let message = `String "different type constructors.\ + Expected these two constant type constructors to be the same, but they're different" in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_constant a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_constant b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_operators (a,b) -> + let message = `String "different type constructors.\ + Expected these two n-ary type constructors to be the same, but they're different" in + let a = `String (Format.asprintf "%a" (Ast_typed.PP.type_operator Ast_typed.PP.type_expression) a) in + let b = `String (Format.asprintf "%a" (Ast_typed.PP.type_operator Ast_typed.PP.type_expression) b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_operator_number_of_arguments (opa, opb, lena, lenb) -> + let message = `String "different number of arguments to type constructors.\ + Expected these two n-ary type constructors to be the same, but they have different number\ + of arguments" in + let a = `String (Format.asprintf "%a" (Ast_typed.PP.type_operator Ast_typed.PP.type_expression) opa) in + let b = `String (Format.asprintf "%a" (Ast_typed.PP.type_operator Ast_typed.PP.type_expression) opb) in + let op = `String (Ast_typed.Helpers.type_operator_name opa) in + let len_a = `Int lena in + let len_b = `Int lenb in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ("op", op) ; + ("len_a", len_a) ; + ("len_b", len_b) ; + ] in + json_error ~stage ~content + | `Typer_different_record_props (a,b,ra,rb,ka,kb) -> + let names = if Ast_typed.Helpers.is_tuple_lmap ra &&Ast_typed.Helpers.is_tuple_lmap rb + then "tuples" else "records" in + let message = `String ("different keys in " ^ names) in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ("ka", `String ka) ; + ("kb", `String kb) ; + ] in + json_error ~stage ~content + | `Typer_different_kind_record_tuple (a,b,ra,rb) -> + let name_a = if Ast_typed.Helpers.is_tuple_lmap ra then "tuple" else "record" in + let name_b = if Ast_typed.Helpers.is_tuple_lmap rb then "tuple" else "record" in + let message = `String ("different keys. Expected these two types to be the same, but they're different (one is a " + ^ name_a ^ " and the other is a " ^ name_b ^ ")") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_size_records_tuples (a,b,ra,rb) -> + let n = if Ast_typed.Helpers.is_tuple_lmap ra && Ast_typed.Helpers.is_tuple_lmap rb + then "tuples" else "records" in + let message = `String (n^ " have different sizes. Expected these two types to be the same, but they're \ + different (both are " ^ n ^ ", but with a different number of arguments)") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_size_sums (a,b) -> + let message = `String (" sum types have different sizes. Expected these two types to be the same, but they're \ + different") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_types (name,a,b,err) -> + let message = `String (name ^" are different.\ + Expected these two types to be the same, but they're different") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.type_expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.type_expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ("children", error_jsonformat err) + ] in + json_error ~stage ~content + | `Typer_different_literals (name,a,b) -> + let message = `String (name ^ " are different") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.literal a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.literal b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_values (name,a,b) -> + let message = `String (name ^ " are different") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_literals_because_different_types (name,a,b) -> + let message = `String ("literals have different types: " ^ name) in + let a = `String (Format.asprintf "%a" Ast_typed.PP.literal a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.literal b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_different_values_because_different_types (name,a,b) -> + let message = `String ("values have different types: " ^ name) in + let a = `String (Format.asprintf "%a" Ast_typed.PP.expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_uncomparable_literals (name,a,b) -> + let message = `String (name ^ " are not comparable") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.literal a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.literal b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_uncomparable_values (name,a,b) -> + let message = `String (name ^ " are not comparable") in + let a = `String (Format.asprintf "%a" Ast_typed.PP.expression a) in + let b = `String (Format.asprintf "%a" Ast_typed.PP.expression b) in + let content = `Assoc [ + ("message", message) ; + ("a", a) ; + ("b", b) ; + ] in + json_error ~stage ~content + | `Typer_missing_key_in_record_value k -> + let message = `String "missing keys in one of the records" in + let content = `Assoc [ + ("message", message) ; + ("missing_key", `String k) ; + ] in + json_error ~stage ~content + | `Typer_compare_tracer err -> + let content = `Assoc [ + ("message", `String "not equal") ; + ("children", error_jsonformat err) + ] in json_error ~stage ~content \ No newline at end of file diff --git a/src/passes/09-typing/08-typer-new/compare.ml b/src/passes/09-typing/08-typer-new/compare.ml new file mode 100644 index 000000000..957b2c9c7 --- /dev/null +++ b/src/passes/09-typing/08-typer-new/compare.ml @@ -0,0 +1,165 @@ +open Ast_typed +open Trace +open Typer_common.Errors + +let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : (unit, typer_error) result = match (a.type_content, b.type_content) with + | T_constant ca, T_constant cb -> ( + Assert.assert_true (different_constants ca cb) (ca = cb) + ) + | T_constant _, _ -> fail @@ different_kinds a b + | T_operator opa, T_operator opb -> ( + let%bind (lsta, lstb) = match (opa, opb) with + | TC_option la, TC_option lb + | TC_list la, TC_list lb + | TC_contract la, TC_contract lb + | TC_set la, TC_set lb -> ok @@ ([la], [lb]) + | (TC_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb}) + | (TC_big_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_big_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb}) + -> ok @@ ([ka;va] ,[kb;vb]) + | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ ), + (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ ) + -> fail @@ different_operators opa opb + in + if List.length lsta <> List.length lstb then + fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) + else + trace (different_types "arguments to type operators" a b) + @@ bind_list_iter (fun (a,b) -> assert_type_expression_eq (a,b) )(List.combine lsta lstb) + ) + | T_operator _, _ -> fail @@ different_kinds a b + | T_sum sa, T_sum sb -> ( + let sa' = CMap.to_kv_list sa in + let sb' = CMap.to_kv_list sb in + let aux ((ka, {ctor_type=va;_}), (kb, {ctor_type=vb;_})) = + let%bind _ = + Assert.assert_true (corner_case "different keys in sum types") + @@ (ka = kb) in + assert_type_expression_eq (va, vb) + in + let%bind _ = + Assert.assert_list_same_size (different_size_sums a b) + sa' sb' + in + trace (different_types "sum type" a b) @@ + bind_list_iter aux (List.combine sa' sb') + ) + | T_sum _, _ -> fail @@ different_kinds a b + | T_record ra, T_record rb + when Helpers.is_tuple_lmap ra <> Helpers.is_tuple_lmap rb -> ( + fail @@ different_kind_record_tuple a b ra rb + ) + | T_record ra, T_record rb -> ( + let sort_lmap r' = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) r' in + let ra' = sort_lmap @@ LMap.to_kv_list ra in + let rb' = sort_lmap @@ LMap.to_kv_list rb in + let aux ((ka, {field_type=va;_}), (kb, {field_type=vb;_})) = + let%bind _ = + trace (different_types "records" a b) @@ + let Label ka = ka in + let Label kb = kb in + Assert.assert_true (different_props_in_record a b ra rb ka kb) (ka = kb) in + assert_type_expression_eq (va, vb) + in + let%bind _ = + Assert.assert_list_same_size (different_size_records_tuples a b ra rb) ra' rb' in + trace (different_types "record type" a b) + @@ bind_list_iter aux (List.combine ra' rb') + + ) + | T_record _, _ -> fail @@ different_kinds a b + | T_arrow {type1;type2}, T_arrow {type1=type1';type2=type2'} -> + let%bind _ = assert_type_expression_eq (type1, type1') in + let%bind _ = assert_type_expression_eq (type2, type2') in + ok () + | T_arrow _, _ -> fail @@ different_kinds a b + | T_variable x, T_variable y -> let _ = (x = y) in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding" + | T_variable _, _ -> fail @@ different_kinds a b + +(* No information about what made it fail *) +let type_expression_eq ab = Trace.to_bool @@ assert_type_expression_eq ab + +let assert_literal_eq (a, b : literal * literal) : (unit, typer_error) result = + match (a, b) with + | Literal_int a, Literal_int b when a = b -> ok () + | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b + | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b + | Literal_nat a, Literal_nat b when a = b -> ok () + | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b + | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b + | Literal_timestamp a, Literal_timestamp b when a = b -> ok () + | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b + | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b + | Literal_mutez a, Literal_mutez b when a = b -> ok () + | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b + | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b + | Literal_string a, Literal_string b when a = b -> ok () + | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b + | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b + | Literal_bytes a, Literal_bytes b when a = b -> ok () + | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytes" a b + | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b + | Literal_void, Literal_void -> ok () + | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b + | Literal_unit, Literal_unit -> ok () + | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b + | Literal_address a, Literal_address b when a = b -> ok () + | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b + | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b + | Literal_signature a, Literal_signature b when a = b -> ok () + | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b + | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b + | Literal_key a, Literal_key b when a = b -> ok () + | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b + | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b + | Literal_key_hash a, Literal_key_hash b when a = b -> ok () + | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b + | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b + | Literal_chain_id a, Literal_chain_id b when a = b -> ok () + | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b + | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b + | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b + | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b + + +let rec assert_value_eq (a, b: (expression*expression)) : (unit, typer_error) result = + trace compare_tracer @@ + match (a.expression_content, b.expression_content) with + | E_literal a, E_literal b -> + assert_literal_eq (a, b) + | E_constant {cons_name=ca;arguments=lsta}, E_constant {cons_name=cb;arguments=lstb} when ca = cb -> ( + let%bind lst = + generic_try (corner_case "constants with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_constant _, E_constant _ -> + fail @@ different_values "constants" a b + | E_constant _, _ -> + fail @@ (corner_case "comparing constant with other stuff") + + | E_constructor {constructor=ca;element=a}, E_constructor {constructor=cb;element=b} when ca = cb -> ( + let%bind _eq = assert_value_eq (a, b) in + ok () + ) + | E_constructor _, E_constructor _ -> + fail @@ different_values "constructors" a b + | E_constructor _, _ -> + fail @@ different_values_because_different_types "constructor vs. non-constructor" a b + | E_record sma, E_record smb -> ( + let aux (Label k) a b = + match a, b with + | Some a, Some b -> Some (assert_value_eq (a, b)) + | _ -> Some (fail @@ missing_key_in_record_value k) + in + let%bind _all = Helpers.bind_lmap @@ LMap.merge aux sma smb in + ok () + ) + | E_record _, _ -> + fail @@ (different_values_because_different_types "record vs. non-record" a b) + + | (E_literal _, _) | (E_variable _, _) | (E_application _, _) + | (E_lambda _, _) | (E_let_in _, _) | (E_raw_code _, _) | (E_recursive _, _) + | (E_record_accessor _, _) | (E_record_update _,_) + | (E_matching _, _) + -> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b diff --git a/src/passes/09-typing/08-typer-new/typer.ml b/src/passes/09-typing/08-typer-new/typer.ml index 6b690ceb5..72d986205 100644 --- a/src/passes/09-typing/08-typer-new/typer.ml +++ b/src/passes/09-typing/08-typer-new/typer.ml @@ -14,8 +14,7 @@ module Map = RedBlackTrees.PolyMap open Todo_use_fold_generator let assert_type_expression_eq ((tv',tv):O.type_expression * O.type_expression) : (unit,typer_error) result = - trace_option (assert_equal tv' tv) @@ - O.assert_type_expression_eq (tv' , tv) + Compare.assert_type_expression_eq (tv' , tv) (* Extract pairs of (name,type) in the declaration and add it to the environment @@ -67,8 +66,8 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin let%bind acc = match acc with | None -> ok (Some variant) | Some variant' -> - let%bind () = trace_option (not_matching variant variant') @@ - Ast_typed.assert_type_expression_eq (variant , variant') in + let%bind () = + assert_type_expression_eq (variant , variant') in ok (Some variant) in ok acc in diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 19c0e42bd..ff825eb60 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -545,6 +545,9 @@ module Assert = struct let assert_list_empty err lst = assert_true err List.(length lst = 0) + + let assert_list_same_size err lsta lstb = + assert_true err List.(length lsta = length lstb) end From 0dc4315359915674863a88414203c4c841f06247 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 24 Jun 2020 20:23:36 +0100 Subject: [PATCH 09/10] compare (lowercase) has a bit of a special meaning in OCaml, renaming the Compare module to Compare_types for now to avoid potential confusion (?) --- .../09-typing/08-typer-new/{compare.ml => compare_types.ml} | 0 src/passes/09-typing/08-typer-new/typer.ml | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename src/passes/09-typing/08-typer-new/{compare.ml => compare_types.ml} (100%) diff --git a/src/passes/09-typing/08-typer-new/compare.ml b/src/passes/09-typing/08-typer-new/compare_types.ml similarity index 100% rename from src/passes/09-typing/08-typer-new/compare.ml rename to src/passes/09-typing/08-typer-new/compare_types.ml diff --git a/src/passes/09-typing/08-typer-new/typer.ml b/src/passes/09-typing/08-typer-new/typer.ml index 72d986205..2406858a8 100644 --- a/src/passes/09-typing/08-typer-new/typer.ml +++ b/src/passes/09-typing/08-typer-new/typer.ml @@ -14,7 +14,7 @@ module Map = RedBlackTrees.PolyMap open Todo_use_fold_generator let assert_type_expression_eq ((tv',tv):O.type_expression * O.type_expression) : (unit,typer_error) result = - Compare.assert_type_expression_eq (tv' , tv) + Compare_types.assert_type_expression_eq (tv' , tv) (* Extract pairs of (name,type) in the declaration and add it to the environment From bc259fcde77f80208aaa67a3b991d26321df71a0 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Mon, 29 Jun 2020 13:05:34 +0000 Subject: [PATCH 10/10] Feature/transpiler --- src/bin/cli.ml | 59 +- src/bin/expect_tests/help_tests.ml | 12 + src/bin/expect_tests/transpiler_test.ml | 2085 +++++++++++++++++ src/main/compile/helpers.ml | 54 +- src/main/compile/of_core.ml | 6 +- src/main/compile/of_imperative.ml | 4 - src/main/compile/of_source.ml | 8 +- src/main/compile/of_sugar.ml | 4 - src/main/{uncompile => decompile}/dune | 19 +- .../{uncompile => decompile}/formatter.ml | 0 src/main/decompile/helpers.ml | 78 + src/main/decompile/of_core.ml | 10 + src/main/decompile/of_imperative.ml | 10 + .../of_michelson.ml} | 30 +- src/main/decompile/of_sugar.ml | 10 + src/main/dune | 2 +- src/main/main.ml | 4 +- src/main/main_errors/formatter.ml | 18 +- src/main/main_errors/main_errors.ml | 9 +- src/main/main_errors/types.ml | 11 +- src/passes/01-parsing/cameligo.ml | 33 +- src/passes/01-parsing/cameligo.mli | 7 +- src/passes/01-parsing/cameligo/Parser.mly | 22 +- src/passes/01-parsing/cameligo/Pretty.ml | 33 +- src/passes/01-parsing/pascaligo.ml | 21 + src/passes/01-parsing/pascaligo.mli | 5 + src/passes/01-parsing/pascaligo/Parser.mly | 37 +- src/passes/01-parsing/pascaligo/Pretty.ml | 19 +- .../pascaligo/error.messages.checked-in | 24 - src/passes/01-parsing/reasonligo.ml | 33 +- src/passes/01-parsing/reasonligo.mli | 9 +- src/passes/01-parsing/reasonligo/Parser.mly | 28 +- src/passes/01-parsing/reasonligo/Pretty.ml | 23 +- .../03-tree_abstraction/cameligo/cameligo.ml | 6 +- .../03-tree_abstraction/cameligo/cameligo.mli | 4 +- .../03-tree_abstraction/cameligo/compiler.ml | 8 +- .../cameligo/decompiler.ml | 504 ++++ .../03-tree_abstraction/pascaligo/compiler.ml | 32 +- .../pascaligo/decompiler.ml | 660 ++++++ .../pascaligo/pascaligo.ml | 10 +- .../pascaligo/pascaligo.mli | 10 +- src/passes/05-purification/compiler.ml | 22 +- src/passes/07-desugaring/compiler.ml | 55 +- src/passes/07-desugaring/decompiler.ml | 190 +- src/passes/08-self_ast_core/helpers.ml | 17 +- src/passes/09-typing/08-typer-new/typer.ml | 8 +- src/passes/09-typing/08-typer-new/wrap.ml | 2 +- src/passes/09-typing/08-typer-old/typer.ml | 20 +- src/passes/10-self_ast_typed/helpers.ml | 2 +- src/passes/predefined/predefined.ml | 214 ++ src/passes/predefined/predefined.mli | 8 +- src/stages/1-cst/cameligo/CST.ml | 7 +- src/stages/1-cst/cameligo/ParserLog.ml | 50 +- src/stages/1-cst/pascaligo/CST.ml | 17 +- src/stages/1-cst/pascaligo/ParserLog.ml | 44 +- src/stages/1-cst/pascaligo/ParserLog.mli | 1 + src/stages/2-ast_imperative/types.ml | 2 +- src/stages/4-ast_core/PP.ml | 90 +- src/stages/4-ast_core/combinators.ml | 155 +- src/stages/4-ast_core/combinators.mli | 132 +- src/stages/4-ast_core/dune | 1 + src/stages/4-ast_core/misc.ml | 2 +- src/stages/4-ast_core/types.ml | 39 +- src/stages/common/types.ml | 1 - src/stages/ligo_interpreter/PP.ml | 2 +- src/stages/typesystem/misc.ml | 6 +- src/test/coase_tests.ml | 4 +- .../contracts/expected/FA1.2.ligo.expected | 6 +- .../contracts/expected/FA1.2.mligo.expected | 122 +- .../contracts/expected/address.mligo.expected | 4 +- .../expected/amount_lambda.mligo.expected | 4 +- .../contracts/expected/assert.mligo.expected | 4 +- .../expected/attributes.mligo.expected | 8 +- .../contracts/expected/big_map.mligo.expected | 4 +- .../expected/bytes_unpack.mligo.expected | 12 +- .../contracts/expected/closure.mligo.expected | 8 +- .../condition-shadowing.mligo.expected | 16 +- .../expected/create_contract.mligo.expected | 4 +- .../double_michelson_or.mligo.expected | 6 +- .../contracts/expected/fibo.mligo.expected | 4 +- .../contracts/expected/fibo2.mligo.expected | 4 +- .../contracts/expected/fibo3.mligo.expected | 4 +- .../expected/guess_string.mligo.expected | 10 +- src/test/contracts/expected/id.ligo.expected | 6 +- .../expected/multisig-v2.ligo.expected | 3 +- .../expected/time-lock.ligo.expected | 3 +- src/test/integration_tests.ml | 4 +- src/test/test_helpers.ml | 4 +- src/test/time_lock_repeat_tests.ml | 4 +- vendors/ligo-utils/simple-utils/trace.ml | 4 + vendors/ligo-utils/simple-utils/x_list.ml | 1 + 91 files changed, 4562 insertions(+), 739 deletions(-) create mode 100644 src/bin/expect_tests/transpiler_test.ml rename src/main/{uncompile => decompile}/dune (54%) rename src/main/{uncompile => decompile}/formatter.ml (100%) create mode 100644 src/main/decompile/helpers.ml create mode 100644 src/main/decompile/of_core.ml create mode 100644 src/main/decompile/of_imperative.ml rename src/main/{uncompile/uncompile.ml => decompile/of_michelson.ml} (54%) create mode 100644 src/main/decompile/of_sugar.ml create mode 100644 src/passes/03-tree_abstraction/cameligo/decompiler.ml create mode 100644 src/passes/03-tree_abstraction/pascaligo/decompiler.ml diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 4dabdbb1e..9484d8867 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -137,9 +137,9 @@ let optimize = value @@ opt (some string) None info -module Helpers = Ligo.Compile.Helpers -module Compile = Ligo.Compile -module Uncompile = Ligo.Uncompile +module Helpers = Ligo.Compile.Helpers +module Compile = Ligo.Compile +module Decompile = Ligo.Decompile module Run = Ligo.Run.Of_michelson let compile_file = @@ -285,7 +285,7 @@ let compile_parameter = let interpret = let f expression init_file syntax amount balance sender source predecessor_timestamp display_format = - return_result ~display_format (Uncompile.Formatter.expression_format) @@ + return_result ~display_format (Decompile.Formatter.expression_format) @@ let%bind (decl_list,state,env) = match init_file with | Some init_file -> let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in @@ -299,7 +299,7 @@ let interpret = let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in - Uncompile.uncompile_expression typed_exp.type_expression runres + Decompile.Of_michelson.decompile_expression typed_exp.type_expression runres in let term = Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in @@ -345,7 +345,7 @@ let compile_storage = let dry_run = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = - return_result ~display_format (Uncompile.Formatter.expression_format) @@ + return_result ~display_format (Decompile.Formatter.expression_format) @@ let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in let env = Ast_typed.program_environment Environment.default typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -359,7 +359,7 @@ let dry_run = let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in - Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres + Decompile.Of_michelson.decompile_typed_program_entry_function_result typed_prg entry_point runres in let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in @@ -369,7 +369,7 @@ let dry_run = let run_function = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format = - return_result ~display_format (Uncompile.Formatter.expression_format) @@ + return_result ~display_format (Decompile.Formatter.expression_format) @@ let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in let env = Ast_typed.program_environment Environment.default typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -386,7 +386,7 @@ let run_function = let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in - Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres + Decompile.Of_michelson.decompile_typed_program_entry_function_result typed_prg entry_point runres in let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in @@ -396,14 +396,14 @@ let run_function = let evaluate_value = let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format = - return_result ~display_format Uncompile.Formatter.expression_format @@ + return_result ~display_format Decompile.Formatter.expression_format @@ let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in let%bind mini_c = Compile.Of_typed.compile typed_prg in let%bind (exp,_) = trace_option Main_errors.entrypoint_not_found @@ Mini_c.get_entry mini_c entry_point in let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind runres = Run.run_expression ~options compiled.expr compiled.expr_ty in - Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point runres + Decompile.Of_michelson.decompile_typed_program_entry_expression_result typed_prg entry_point runres in let term = Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in @@ -449,6 +449,41 @@ let list_declarations = let doc = "Subcommand: List all the top-level declarations." in (Term.ret term , Term.info ~doc cmdname) +let transpile_contract = + let f source_file new_syntax syntax display_format = + return_result ~display_format (Parser.Formatter.ppx_format) @@ + let%bind core = Compile.Utils.to_core source_file syntax in + let%bind sugar = Decompile.Of_core.decompile core in + let%bind imperative = Decompile.Of_sugar.decompile sugar in + let%bind buffer = Decompile.Of_imperative.decompile imperative (Syntax_name new_syntax) in + ok @@ buffer + in + let term = + Term.(const f $ source_file 0 $ req_syntax 1 $ syntax $ display_format) in + let cmdname = "transpile-contract" in + let doc = "Subcommand: Transpile a contract to another syntax." in + (Term.ret term , Term.info ~doc cmdname) + +let transpile_expression = + let f expression new_syntax syntax display_format = + return_result ~display_format (Parser.Formatter.ppx_format) @@ + let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) None in + let%bind n_syntax = Decompile.Helpers.syntax_to_variant (Syntax_name new_syntax) None in + let%bind imperative = Compile.Of_source.compile_expression v_syntax expression in + let%bind sugar = Compile.Of_imperative.compile_expression imperative in + let%bind core = Compile.Of_sugar.compile_expression sugar in + let%bind sugar = Decompile.Of_core.decompile_expression core in + let%bind imperative = Decompile.Of_sugar.decompile_expression sugar in + let%bind buffer = Decompile.Of_imperative.decompile_expression imperative n_syntax in + ok @@ buffer + in + let term = + Term.(const f $ expression "" 1 $ req_syntax 2 $ req_syntax 0 $ display_format) in + let cmdname = "transpile-expression" in + let doc = "Subcommand: Transpile an expression to another syntax." in + (Term.ret term , Term.info ~doc cmdname) + + let run ?argv () = Term.eval_choice ?argv main [ temp_ligo_interpreter ; @@ -457,6 +492,8 @@ let run ?argv () = compile_parameter ; compile_storage ; compile_expression ; + transpile_contract ; + transpile_expression ; interpret ; dry_run ; run_function ; diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml index 4c00c7969..5a3bce777 100644 --- a/src/bin/expect_tests/help_tests.ml +++ b/src/bin/expect_tests/help_tests.ml @@ -87,6 +87,12 @@ let%expect_test _ = run-function Subcommand: Run a function with the given parameter. + transpile-contract + Subcommand: Transpile a contract to another syntax. + + transpile-expression + Subcommand: Transpile an expression to another syntax. + OPTIONS --help[=FMT] (default=auto) Show this help in format FMT. The value FMT must be one of `auto', @@ -181,6 +187,12 @@ let%expect_test _ = run-function Subcommand: Run a function with the given parameter. + transpile-contract + Subcommand: Transpile a contract to another syntax. + + transpile-expression + Subcommand: Transpile an expression to another syntax. + OPTIONS --help[=FMT] (default=auto) Show this help in format FMT. The value FMT must be one of `auto', diff --git a/src/bin/expect_tests/transpiler_test.ml b/src/bin/expect_tests/transpiler_test.ml new file mode 100644 index 000000000..1110ed54b --- /dev/null +++ b/src/bin/expect_tests/transpiler_test.ml @@ -0,0 +1,2085 @@ +open Cli_expect + +let%expect_test _ = + run_ligo_good [ "transpile-contract" ; "../../test/contracts/coase.ligo" ; "pascaligo" ] ; + [%expect {| + type card_pattern_id is nat + + type card_pattern is + record [quantity : nat; coefficient : tez] + + type card_patterns is map (card_pattern_id, card_pattern) + + type card_id is nat + + type card is + record [ + card_pattern : card_pattern_id; + card_owner : address + ] + + type cards is map (card_id, card) + + type storage is + record [ + next_id : nat; + cards : cards; + card_patterns : card_patterns + ] + + type return is list (operation) * storage + + type action_buy_single is + record [card_to_buy : card_pattern_id] + + type action_sell_single is record [card_to_sell : card_id] + + type action_transfer_single is + record [destination : address; card_to_transfer : card_id] + + type parameter is + Transfer_single of action_transfer_single + | Sell_single of action_sell_single + | Buy_single of action_buy_single + + function transfer_single + (const gen__parameters4 : action_transfer_single * storage) + : return is + case gen__parameters4 of [ + (action, s) -> + block { + const cards : cards = s.cards; + const card : card + = case cards [action.card_to_transfer] of [ + Some (card) -> card + | None -> + (failwith ("transfer_single: No card.") + : card) + ]; + if NEQ (card.card_owner, Tezos.sender) + then failwith ("This card doesn't belong to you") + else skip; + card.card_owner := action.destination; + cards [action.card_to_transfer] := card; + s.cards := cards + } with ((list [] : list (operation)), s) + ] + + function sell_single + (const gen__parameters3 : action_sell_single * storage) + : return is + case gen__parameters3 of [ + (action, s) -> + block { + const card : card + = case s.cards [action.card_to_sell] of [ + Some (card) -> card + | None -> + (failwith ("sell_single: No card.") : card) + ]; + if NEQ (card.card_owner, Tezos.sender) + then failwith ("This card doesn't belong to you") + else skip; + const card_pattern : card_pattern + = case s.card_patterns [card.card_pattern] of [ + Some (pattern) -> pattern + | None -> + (failwith ("sell_single: No card pattern.") + : card_pattern) + ]; + card_pattern.quantity := + abs (SUB (card_pattern.quantity, 1n)); + const card_patterns : card_patterns + = s.card_patterns; + card_patterns [card.card_pattern] := card_pattern; + s.card_patterns := card_patterns; + const cards : cards = s.cards; + const cards + = Map.remove (action.card_to_sell, cards); + s.cards := cards; + const price : tez + = TIMES + (card_pattern.coefficient, card_pattern.quantity); + const receiver : contract (unit) + = case (Tezos.get_contract_opt (Tezos.sender) + : option (contract (unit))) + of [ + Some (contract) -> contract + | None -> + (failwith ("sell_single: No contract.") + : contract (unit)) + ]; + const op : operation + = Tezos.transaction (unit, price, receiver); + const operations : list (operation) = list [op] + } with (operations, s) + ] + + function buy_single + (const gen__parameters2 : action_buy_single * storage) + : return is + case gen__parameters2 of [ + (action, s) -> + block { + const card_pattern : card_pattern + = case s.card_patterns [action.card_to_buy] of [ + Some (pattern) -> pattern + | None -> + (failwith ("buy_single: No card pattern.") + : card_pattern) + ]; + const price : tez + = TIMES + (card_pattern.coefficient, + ADD (card_pattern.quantity, 1n)); + if GT (price, Tezos.amount) + then failwith ("Not enough money") + else skip; + card_pattern.quantity := + ADD (card_pattern.quantity, 1n); + const card_patterns : card_patterns + = s.card_patterns; + card_patterns [action.card_to_buy] := card_pattern; + s.card_patterns := card_patterns; + const cards : cards = s.cards; + cards [s.next_id] := + record [ + card_pattern = action.card_to_buy; + card_owner = Tezos.sender + ]; + s.cards := cards; + s.next_id := ADD (s.next_id, 1n) + } with ((list [] : list (operation)), s) + ] + + function main (const gen__parameters1 : parameter * storage) + : return is + case gen__parameters1 of [ + (action, s) -> + case action of [ + Buy_single (bs) -> buy_single (bs, s) + | Sell_single (as) -> sell_single (as, s) + | Transfer_single (at) -> transfer_single (at, s) + ] + ] |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/coase.ligo" ; "cameligo" ] ; + [%expect {| + type card_pattern_id = nat + + type card_pattern = {quantity : nat; coefficient : tez} + + type card_patterns = (card_pattern_id, card_pattern) map + + type card_id = nat + + type card = + {card_pattern : card_pattern_id; card_owner : address} + + type cards = (card_id, card) map + + type storage = + {next_id : nat; + cards : cards; + card_patterns : card_patterns} + + type return = operation list * storage + + type action_buy_single = {card_to_buy : card_pattern_id} + + type action_sell_single = {card_to_sell : card_id} + + type action_transfer_single = + {destination : address; card_to_transfer : card_id} + + type parameter = + Transfer_single of action_transfer_single + | Sell_single of action_sell_single + | Buy_single of action_buy_single + + let transfer_single + : action_transfer_single * storage -> return = + (fun gen__parameters4 : action_transfer_single * storage -> + match gen__parameters4 with + action : action_transfer_single, s : storage -> + let cards : cards = s.cards in + let card : card = + match Map.find_opt action.card_to_transfer cards + with + Some card -> card + | None -> + ((failwith ("transfer_single: No card.")) + : card) in + begin + if (NEQ (card.card_owner) (Tezos.sender)) + then + (failwith ("This card doesn't belong to you")) + else (); + let card = + {card with + {card_owner = action.destination}} in + let cards = + Map.add card action.card_to_transfer cards in + let s = {s with {cards = cards}} in + ([] : operation list), s + end) + + let sell_single : action_sell_single * storage -> return = + (fun gen__parameters3 : action_sell_single * storage -> + match gen__parameters3 with + action : action_sell_single, s : storage -> + let card : card = + match Map.find_opt action.card_to_sell s.cards + with + Some card -> card + | None -> + ((failwith ("sell_single: No card.")) : card) in + begin + if (NEQ (card.card_owner) (Tezos.sender)) + then + (failwith ("This card doesn't belong to you")) + else (); + let card_pattern : card_pattern = + match Map.find_opt + card.card_pattern + s.card_patterns + with + Some pattern -> pattern + | None -> + ((failwith + ("sell_single: No card pattern.")) + : card_pattern) in + let card_pattern = + {card_pattern with + {quantity = + (abs ((SUB (card_pattern.quantity) (1n))))}} in + let card_patterns : card_patterns = + s.card_patterns in + let card_patterns = + Map.add + card_pattern + card.card_pattern + card_patterns in + let s = {s with {card_patterns = card_patterns}} in + let cards : cards = s.cards in + let cards = + (Map.remove (action.card_to_sell) (cards)) in + let s = {s with {cards = cards}} in + let price : tez = + (TIMES + (card_pattern.coefficient) + (card_pattern.quantity)) in + let receiver : unit contract = + match ((Tezos.get_contract_opt (Tezos.sender)) + : unit contract option) + with + Some contract -> contract + | None -> + ((failwith ("sell_single: No contract.")) + : unit contract) in + let op : operation = + (Tezos.transaction (unit) (price) (receiver)) in + let operations : operation list = [op] in + operations, s + end) + + let buy_single : action_buy_single * storage -> return = + (fun gen__parameters2 : action_buy_single * storage -> + match gen__parameters2 with + action : action_buy_single, s : storage -> + let card_pattern : card_pattern = + match Map.find_opt + action.card_to_buy + s.card_patterns + with + Some pattern -> pattern + | None -> + ((failwith ("buy_single: No card pattern.")) + : card_pattern) in + let price : tez = + (TIMES + (card_pattern.coefficient) + ((ADD (card_pattern.quantity) (1n)))) in + begin + if (GT (price) (Tezos.amount)) + then (failwith ("Not enough money")) + else (); + let card_pattern = + {card_pattern with + {quantity = + (ADD (card_pattern.quantity) (1n))}} in + let card_patterns : card_patterns = + s.card_patterns in + let card_patterns = + Map.add + card_pattern + action.card_to_buy + card_patterns in + let s = {s with {card_patterns = card_patterns}} in + let cards : cards = s.cards in + let cards = + Map.add + {card_pattern = action.card_to_buy; + card_owner = Tezos.sender} + s.next_id + cards in + let s = {s with {cards = cards}} in + let s = + {s with + {next_id = (ADD (s.next_id) (1n))}} in + ([] : operation list), s + end) + + let main : parameter * storage -> return = + (fun gen__parameters1 : parameter * storage -> + match gen__parameters1 with + action : parameter, s : storage -> + match action with + Buy_single bs -> buy_single bs s + | Sell_single as -> sell_single as s + | Transfer_single at -> transfer_single at s) |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/coase.ligo" ; "reasonligo" ] ; + [%expect {| + type card_pattern_id = nat; + + type card_pattern = {quantity: nat, coefficient: tez }; + + type card_patterns = map(card_pattern_id, card_pattern); + + type card_id = nat; + + type card = { + card_pattern: card_pattern_id, + card_owner: address + }; + + type cards = map(card_id, card); + + type storage = {next_id: nat, cards, card_patterns }; + + type return = (list(operation), storage); + + type action_buy_single = {card_to_buy: card_pattern_id }; + + type action_sell_single = {card_to_sell: card_id }; + + type action_transfer_single = { + destination: address, + card_to_transfer: card_id + }; + + type parameter = + Transfer_single(action_transfer_single) + | Sell_single(action_sell_single) + | Buy_single(action_buy_single); + + let transfer_single + : ((action_transfer_single, storage)) => return = + ((gen__parameters4: (action_transfer_single, storage)) => + switch(gen__parameters4) { + | (action: action_transfer_single, s: storage) => + let cards: cards = s.cards; + let card: card = + switch( + Map.find_opt(action.card_to_transfer, cards)) { + | Somecard => card + | None => + (failwith(("transfer_single: No card."))) + : card + }; + begin + if ((NEQ((card.card_owner), (Tezos.sender)))) { + (failwith(("This card doesn't belong to you"))) + } else { + () + }; + let card = + {...card, + {card_owner: action.destination }}; + let cards = + Map.add(card, action.card_to_transfer, cards); + let s = {...s, {cards: cards }}; + ([] : list(operation), s) + end + }); + + let sell_single + : ((action_sell_single, storage)) => return = + ((gen__parameters3: (action_sell_single, storage)) => + switch(gen__parameters3) { + | (action: action_sell_single, s: storage) => + let card: card = + switch(Map.find_opt(action.card_to_sell, s.cards)) { + | Somecard => card + | None => + (failwith(("sell_single: No card."))) : card + }; + begin + if ((NEQ((card.card_owner), (Tezos.sender)))) { + (failwith(("This card doesn't belong to you"))) + } else { + () + }; + let card_pattern: card_pattern = + switch( + Map.find_opt(card.card_pattern, + s.card_patterns)) { + | Somepattern => pattern + | None => + ( + failwith(("sell_single: No card pattern."))) + : card_pattern + }; + let card_pattern = + {...card_pattern, + { + quantity: + ( + abs(((SUB((card_pattern.quantity), (1n)))))) + }}; + let card_patterns: card_patterns = + s.card_patterns; + let card_patterns = + + Map.add(card_pattern, + card.card_pattern, + card_patterns); + let s = {...s, {card_patterns: card_patterns }}; + let cards: cards = s.cards; + let cards = + (Map.remove((action.card_to_sell), (cards))); + let s = {...s, {cards: cards }}; + let price: tez = + ( + TIMES((card_pattern.coefficient), + (card_pattern.quantity))); + let receiver: contract(unit) = + switch((Tezos.get_contract_opt((Tezos.sender))) + : option(contract(unit))) { + | Somecontract => contract + | None => + (failwith(("sell_single: No contract."))) + : contract(unit) + }; + let op: operation = + (Tezos.transaction((unit), (price), (receiver))); + let operations: list(operation) = [op]; + (operations, s) + end + }); + + let buy_single: ((action_buy_single, storage)) => return = + ((gen__parameters2: (action_buy_single, storage)) => + switch(gen__parameters2) { + | (action: action_buy_single, s: storage) => + let card_pattern: card_pattern = + switch( + Map.find_opt(action.card_to_buy, s.card_patterns)) { + | Somepattern => pattern + | None => + (failwith(("buy_single: No card pattern."))) + : card_pattern + }; + let price: tez = + ( + TIMES((card_pattern.coefficient), + ((ADD((card_pattern.quantity), (1n)))))); + begin + if ((GT((price), (Tezos.amount)))) { + (failwith(("Not enough money"))) + } else { + () + }; + let card_pattern = + {...card_pattern, + { + quantity: + (ADD((card_pattern.quantity), (1n))) + }}; + let card_patterns: card_patterns = + s.card_patterns; + let card_patterns = + + Map.add(card_pattern, + action.card_to_buy, + card_patterns); + let s = {...s, {card_patterns: card_patterns }}; + let cards: cards = s.cards; + let cards = + + Map.add({ + card_pattern: action.card_to_buy, + card_owner: Tezos.sender + }, + s.next_id, + cards); + let s = {...s, {cards: cards }}; + let s = + {...s, + {next_id: (ADD((s.next_id), (1n))) }}; + ([] : list(operation), s) + end + }); + + let main: ((parameter, storage)) => return = + ((gen__parameters1: (parameter, storage)) => + switch(gen__parameters1) { + | (action: parameter, s: storage) => + switch(action) { + | Buy_single bs => buy_single(bs, s) + | Sell_single as => sell_single(as, s) + | Transfer_single at => transfer_single(at, s) + } + }); |}] + +let%expect_test _ = + run_ligo_good [ "transpile-contract" ; "../../test/contracts/deep_access.ligo" ; "pascaligo" ] ; + [%expect{| + type pii is int * int + + type ppi is record [y : pii; x : pii] + + type ppp is ppi * ppi + + function main (const toto : unit) : int is + block { + const a : ppp + = (record [y = (10, 11); x = (0, 1)], + record [y = (110, 111); x = (100, 101)]); + a.0.x.0 := 2 + } with a.0.x.0 + + function asymetric_tuple_access (const foo : unit) : int is + block { + const tuple : int * int * int * int = (0, (1, (2, 3))) + } with + ADD + (ADD (ADD (tuple.0, tuple.1.0), tuple.1.1.0), + tuple.1.1.1) + + type nested_record_t is + record [nesty : record [mymap : map (int, string)]] + + function nested_record (const nee : nested_record_t) + : string is + block { + nee.nesty.mymap [1] := "one" + } with + case nee.nesty.mymap [1] of [ + Some (s) -> s + | None -> (failwith ("Should not happen.") : string) + ] |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/deep_access.ligo" ; "cameligo" ] ; + [%expect{| + type pii = int * int + + type ppi = {y : pii; x : pii} + + type ppp = ppi * ppi + + let main : unit -> int = + (fun toto : unit -> + let a : ppp = + {y = 10, 11; x = 0, 1}, {y = 110, 111; x = 100, 101} in + let a = {a with {0.x.0 = 2}} in + a.0.x.0) + + let asymetric_tuple_access : unit -> int = + (fun foo : unit -> + let tuple : int * int * int * int = 0, 1, 2, 3 in + (ADD + ((ADD ((ADD (tuple.0) (tuple.1.0))) (tuple.1.1.0))) + (tuple.1.1.1))) + + type nested_record_t = {nesty : {mymap : (int, string) map}} + + let nested_record : nested_record_t -> string = + (fun nee : nested_record_t -> + let nee = Map.add "one" 1 nesty.mymap in + match Map.find_opt 1 nee.nesty.mymap with + Some s -> s + | None -> ((failwith ("Should not happen.")) : string)) |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/deep_access.ligo" ; "reasonligo" ] ; + [%expect{| + type pii = (int, int); + + type ppi = {y: pii, x: pii }; + + type ppp = (ppi, ppi); + + let main: unit => int = + ((toto: unit) => + let a: ppp = + ({ + y: (10, 11), + x: (0, 1) + }, {y: (110, 111), x: (100, 101) }); + let a = {...a, {0.x[0]: 2 }}; + a[0].x[0]); + + let asymetric_tuple_access: unit => int = + ((foo: unit) => + let tuple: (int, (int, (int, int))) = (0, (1, (2, 3))); + ( + ADD((( + ADD(((ADD((tuple[0]), (tuple[1][0])))), + (tuple[1][1][0])))), + (tuple[1][1][1])))); + + type nested_record_t = {nesty: {mymap: map(int, string) } }; + + let nested_record: nested_record_t => string = + ((nee: nested_record_t) => + let nee = Map.add("one", 1, nesty.mymap); + switch(Map.find_opt(1, nee.nesty.mymap)) { + | Somes => s + | None => (failwith(("Should not happen."))) : string + }); |}] + +let%expect_test _ = + run_ligo_good [ "transpile-contract" ; "../../test/contracts/double_fold_converter.religo" ; "pascaligo" ] ; + [%expect{| + type tokenId is nat + + type tokenOwner is address + + type tokenAmount is nat + + type transferContents is + record [ + token_id : tokenId; + to_ : tokenOwner; + amount : tokenAmount + ] + + type transfer is + record [txs : list (transferContents); from_ : tokenOwner] + + type transferContentsMichelson is + michelson_pair_right_comb (transferContents) + + type transferAuxiliary is + record [ + txs : list (transferContentsMichelson); + from_ : tokenOwner + ] + + type transferMichelson is + michelson_pair_right_comb (transferAuxiliary) + + type transferParameter is list (transferMichelson) + + type parameter is Transfer of transferParameter + + type storage is big_map (tokenId, tokenOwner) + + type entrypointParameter is parameter * storage + + type entrypointReturn is list (operation) * storage + + const errorTokenUndefined = "TOKEN_UNDEFINED" + + const errorNotOwner = "NOT_OWNER" + + const errorInsufficientBalance = "INSUFFICIENT_BALANCE" + + type transferContentsIteratorAccumulator is + storage * tokenOwner + + function transferContentsIterator + (const gen__P + : transferContentsIteratorAccumulator * + transferContentsMichelson) is + block { + const gen__rhs1 = gen__P; + const accumulator = gen__rhs1.0; + const transferContentsMichelson = gen__rhs1.1; + const gen__rhs2 = accumulator; + const storage = gen__rhs2.0; + const from_ = gen__rhs2.1; + const transferContents + = (Layout.convert_from_right_comb + (transferContentsMichelson) + : transferContents); + const tokenOwner + = (Map.find_opt (transferContents.token_id, storage) + : option (tokenOwner)); + const tokenOwner + = case tokenOwner of [ + Some (tokenOwner) -> + if EQ (tokenOwner, from_) + then tokenOwner + else + (failwith (errorInsufficientBalance) : tokenOwner) + | None -> (failwith (errorTokenUndefined) : tokenOwner) + ]; + const storage + = Map.update + (transferContents.token_id, + Some (transferContents.to_), storage) + } with (storage, from_) + + function allowOnlyOwnTransfer (const from : tokenOwner) is + if NEQ (from, Tezos.sender) + then failwith (errorNotOwner) + else Unit + + function transferIterator + (const gen__P : storage * transferMichelson) is + block { + const gen__rhs7 = gen__P; + const storage = gen__rhs7.0; + const transferMichelson = gen__rhs7.1; + const transferAuxiliary2 + = (Layout.convert_from_right_comb (transferMichelson) + : transferAuxiliary); + const from_ = (transferAuxiliary2.from_ : tokenOwner); + allowOnlyOwnTransfer (from_); + const gen__rhs10 + = List.fold + (transferContentsIterator, transferAuxiliary2.txs, + (storage, from_)); + const storage = gen__rhs10.0; + const _ = gen__rhs10.1 + } with storage + + function transfer + (const gen__P : transferParameter * storage) is + block { + const gen__rhs11 = gen__P; + const transferParameter = gen__rhs11.0; + const storage = gen__rhs11.1; + const storage + = List.fold (transferIterator, transferParameter, storage) + } with ((list [] : list (operation)), storage) + + function main (const gen__P : entrypointParameter) is + block { + const gen__rhs13 = gen__P; + const parameter = gen__rhs13.0; + const storage = gen__rhs13.1 + } with + case parameter of [ + Transfer (transferParameter) -> + transfer (transferParameter, storage) + ] |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/double_fold_converter.religo" ; "cameligo" ] ; + [%expect{| + type tokenId = nat + + type tokenOwner = address + + type tokenAmount = nat + + type transferContents = + {token_id : tokenId; + to_ : tokenOwner; + amount : tokenAmount} + + type transfer = + {txs : transferContents list; from_ : tokenOwner} + + type transferContentsMichelson = + transferContents michelson_pair_right_comb + + type transferAuxiliary = + {txs : transferContentsMichelson list; from_ : tokenOwner} + + type transferMichelson = + transferAuxiliary michelson_pair_right_comb + + type transferParameter = transferMichelson list + + type parameter = Transfer of transferParameter + + type storage = (tokenId, tokenOwner) big_map + + type entrypointParameter = parameter * storage + + type entrypointReturn = operation list * storage + + let errorTokenUndefined = "TOKEN_UNDEFINED" + + let errorNotOwner = "NOT_OWNER" + + let errorInsufficientBalance = "INSUFFICIENT_BALANCE" + + type transferContentsIteratorAccumulator = + storage * tokenOwner + + let transferContentsIterator + : transferContentsIteratorAccumulator * + transferContentsMichelson -> + transferContentsIteratorAccumulator = + (fun gen__P : + transferContentsIteratorAccumulator * + transferContentsMichelson -> + let gen__rhs1 = gen__P in + let accumulator = gen__rhs1.0 in + let transferContentsMichelson = gen__rhs1.1 in + let gen__rhs2 = accumulator in + let storage = gen__rhs2.0 in + let from_ = gen__rhs2.1 in + let transferContents = + ((Layout.convert_from_right_comb + (transferContentsMichelson)) + : transferContents) in + let tokenOwner = + ((Map.find_opt (transferContents.token_id) (storage)) + : tokenOwner option) in + let tokenOwner = + match tokenOwner with + Some tokenOwner -> + if (EQ (tokenOwner) (from_)) + then tokenOwner + else + ((failwith (errorInsufficientBalance)) + : tokenOwner) + | None -> + ((failwith (errorTokenUndefined)) : tokenOwner) in + let storage = + (Map.update + (transferContents.token_id) + ((Some (transferContents.to_))) + (storage)) in + storage, from_) + + let allowOnlyOwnTransfer : tokenOwner -> unit = + (fun from : tokenOwner -> + if (NEQ (from) (Tezos.sender)) + then (failwith (errorNotOwner)) + else ()) + + let transferIterator + : storage * transferMichelson -> storage = + (fun gen__P : storage * transferMichelson -> + let gen__rhs7 = gen__P in + let storage = gen__rhs7.0 in + let transferMichelson = gen__rhs7.1 in + let transferAuxiliary2 = + ((Layout.convert_from_right_comb (transferMichelson)) + : transferAuxiliary) in + let from_ = (transferAuxiliary2.from_ : tokenOwner) in + begin + allowOnlyOwnTransfer from_; + let gen__rhs10 = + (List.fold + (transferContentsIterator) + (transferAuxiliary2.txs) + (storage, from_)) in + let storage = gen__rhs10.0 in + let _ = gen__rhs10.1 in + storage + end) + + let transfer + : transferParameter * storage -> entrypointReturn = + (fun gen__P : transferParameter * storage -> + let gen__rhs11 = gen__P in + let transferParameter = gen__rhs11.0 in + let storage = gen__rhs11.1 in + let storage = + (List.fold + (transferIterator) + (transferParameter) + (storage)) in + ([] : operation list), storage) + + let main : entrypointParameter -> entrypointReturn = + (fun gen__P : entrypointParameter -> + let gen__rhs13 = gen__P in + let parameter = gen__rhs13.0 in + let storage = gen__rhs13.1 in + match parameter with + Transfer transferParameter -> + transfer transferParameter storage) |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/double_fold_converter.religo" ; "reasonligo" ] ; + [%expect{| + type tokenId = nat; + + type tokenOwner = address; + + type tokenAmount = nat; + + type transferContents = { + token_id: tokenId, + to_: tokenOwner, + amount: tokenAmount + }; + + type transfer = { + txs: list(transferContents), + from_: tokenOwner + }; + + type transferContentsMichelson = michelson_pair_right_comb + (transferContents); + + type transferAuxiliary = { + txs: list(transferContentsMichelson), + from_: tokenOwner + }; + + type transferMichelson = michelson_pair_right_comb + (transferAuxiliary); + + type transferParameter = list(transferMichelson); + + type parameter = Transfer(transferParameter); + + type storage = big_map(tokenId, tokenOwner); + + type entrypointParameter = (parameter, storage); + + type entrypointReturn = (list(operation), storage); + + let errorTokenUndefined = "TOKEN_UNDEFINED"; + + let errorNotOwner = "NOT_OWNER"; + + let errorInsufficientBalance = "INSUFFICIENT_BALANCE"; + + type transferContentsIteratorAccumulator = (storage, + tokenOwner); + + let transferContentsIterator + : ((transferContentsIteratorAccumulator, + transferContentsMichelson)) => + transferContentsIteratorAccumulator = + ((gen__P: (transferContentsIteratorAccumulator, + transferContentsMichelson)) => + let gen__rhs1 = gen__P; + let accumulator = gen__rhs1[0]; + let transferContentsMichelson = gen__rhs1[1]; + let gen__rhs2 = accumulator; + let storage = gen__rhs2[0]; + let from_ = gen__rhs2[1]; + let transferContents = + ( + Layout.convert_from_right_comb((transferContentsMichelson))) + : transferContents; + let tokenOwner = + (Map.find_opt((transferContents.token_id), (storage))) + : option(tokenOwner); + let tokenOwner = + switch(tokenOwner) { + | SometokenOwner => + if ((EQ((tokenOwner), (from_)))) { + tokenOwner + } else { + + (failwith((errorInsufficientBalance))) + : tokenOwner + } + | None => + (failwith((errorTokenUndefined))) : tokenOwner + }; + let storage = + ( + Map.update((transferContents.token_id), + ((Some((transferContents.to_)))), + (storage))); + (storage, from_)); + + let allowOnlyOwnTransfer: tokenOwner => unit = + ((from: tokenOwner) => + if ((NEQ((from), (Tezos.sender)))) { + (failwith((errorNotOwner))) + } else { + () + }); + + let transferIterator + : ((storage, transferMichelson)) => storage = + ((gen__P: (storage, transferMichelson)) => + let gen__rhs7 = gen__P; + let storage = gen__rhs7[0]; + let transferMichelson = gen__rhs7[1]; + let transferAuxiliary2 = + (Layout.convert_from_right_comb((transferMichelson))) + : transferAuxiliary; + let from_ = transferAuxiliary2.from_ : tokenOwner; + begin + allowOnlyOwnTransfer(from_); + let gen__rhs10 = + ( + List.fold((transferContentsIterator), + (transferAuxiliary2.txs), + ((storage, from_)))); + let storage = gen__rhs10[0]; + let _ = gen__rhs10[1]; + storage + end); + + let transfer + : ((transferParameter, storage)) => entrypointReturn = + ((gen__P: (transferParameter, storage)) => + let gen__rhs11 = gen__P; + let transferParameter = gen__rhs11[0]; + let storage = gen__rhs11[1]; + let storage = + ( + List.fold((transferIterator), + (transferParameter), + (storage))); + ([] : list(operation), storage)); + + let main: entrypointParameter => entrypointReturn = + ((gen__P: entrypointParameter) => + let gen__rhs13 = gen__P; + let parameter = gen__rhs13[0]; + let storage = gen__rhs13[1]; + switch(parameter) { + | Transfer transferParameter => + transfer(transferParameter, storage) + }); |}] + +let%expect_test _ = + run_ligo_good [ "transpile-contract" ; "../../test/contracts/FA1.2.ligo" ; "pascaligo" ] ; + [%expect {| + type tokens is big_map (address, nat) + + type allowances is big_map (address * address, nat) + + type storage is + record [ + total_amount : nat; + tokens : tokens; + allowances : allowances + ] + + type transfer is + record [ + value : nat; + address_to : address; + address_from : address + ] + + type approve is record [value : nat; spender : address] + + type getAllowance is + record [ + spender : address; + owner : address; + callback : contract (nat) + ] + + type getBalance is + record [owner : address; callback : contract (nat)] + + type getTotalSupply is record [callback : contract (nat)] + + type action is + Transfer of transfer | GetTotalSupply of getTotalSupply + | GetBalance of getBalance | GetAllowance of getAllowance + | Approve of approve + + function transfer + (const gen__parameters6 : transfer * storage) + : list (operation) * storage is + case gen__parameters6 of [ + (p, s) -> + block { + const new_allowances : allowances = big_map []; + const gen__env9 + = record [new_allowances = new_allowances]; + const gen__env9 + = if EQ (Tezos.sender, p.address_from) + then + block { + const new_allowances = s.allowances; + gen__env9.new_allowances := new_allowances; + skip + } with gen__env9 + else + block { + const authorized_value : nat + = case Map.find_opt + ((Tezos.sender, p.address_from), + s.allowances) + of [ + Some (value) -> value + | None -> 0n + ]; + const gen__env8 + = record [new_allowances = new_allowances]; + const gen__env8 + = if LT (authorized_value, p.value) + then + block { + failwith ("Not Enough Allowance") + } with gen__env8 + else + block { + const new_allowances + = Map.update + ((Tezos.sender, p.address_from), + Some + (abs + (SUB + (authorized_value, p.value))), + s.allowances); + gen__env8.new_allowances := + new_allowances; + skip + } with gen__env8; + const new_allowances + = gen__env8.new_allowances; + gen__env9.new_allowances := new_allowances; + skip + } with gen__env9; + const new_allowances = gen__env9.new_allowances; + const sender_balance : nat + = case Map.find_opt (p.address_from, s.tokens) of [ + Some (value) -> value + | None -> 0n + ]; + const new_tokens : tokens = big_map []; + const gen__env12 = record [new_tokens = new_tokens]; + const gen__env12 + = if LT (sender_balance, p.value) + then + block { + failwith ("Not Enough Balance") + } with gen__env12 + else + block { + const new_tokens + = Map.update + (p.address_from, + Some + (abs (SUB (sender_balance, p.value))), + s.tokens); + gen__env12.new_tokens := new_tokens; + const receiver_balance : nat + = case Map.find_opt (p.address_to, s.tokens) + of [ + Some (value) -> value + | None -> 0n + ]; + const new_tokens + = Map.update + (p.address_to, + Some (ADD (receiver_balance, p.value)), + new_tokens); + gen__env12.new_tokens := new_tokens; + skip + } with gen__env12; + const new_tokens = gen__env12.new_tokens + } with + ((list [] : list (operation)), + s with + record [ + allowances = new_allowances; + tokens = new_tokens + ]) + ] + + function approve + (const gen__parameters5 : approve * storage) + : list (operation) * storage is + case gen__parameters5 of [ + (p, s) -> + block { + const previous_value : nat + = case Map.find_opt + ((p.spender, Tezos.sender), s.allowances) + of [ + Some (value) -> value + | None -> 0n + ]; + const new_allowances : allowances = big_map []; + const gen__env14 + = record [new_allowances = new_allowances]; + const gen__env14 + = if AND (GT (previous_value, 0n), GT (p.value, 0n)) + then + block { + failwith ("Unsafe Allowance Change") + } with gen__env14 + else + block { + const new_allowances + = Map.update + ((p.spender, Tezos.sender), + Some (p.value), s.allowances); + gen__env14.new_allowances := new_allowances; + skip + } with gen__env14; + const new_allowances = gen__env14.new_allowances + } with + ((list [] : list (operation)), + s with + record [allowances = new_allowances]) + ] + + function getAllowance + (const gen__parameters4 : getAllowance * storage) + : list (operation) * storage is + case gen__parameters4 of [ + (p, s) -> + block { + const value : nat + = case Map.find_opt + ((p.owner, p.spender), s.allowances) + of [ + Some (value) -> value + | None -> 0n + ]; + const op : operation + = Tezos.transaction (value, 0mutez, p.callback) + } with (list [op], s) + ] + + function getBalance + (const gen__parameters3 : getBalance * storage) + : list (operation) * storage is + case gen__parameters3 of [ + (p, s) -> + block { + const value : nat + = case Map.find_opt (p.owner, s.tokens) of [ + Some (value) -> value + | None -> 0n + ]; + const op : operation + = Tezos.transaction (value, 0mutez, p.callback) + } with (list [op], s) + ] + + function getTotalSupply + (const gen__parameters2 : getTotalSupply * storage) + : list (operation) * storage is + case gen__parameters2 of [ + (p, s) -> + block { + const total : nat = s.total_amount; + const op : operation + = Tezos.transaction (total, 0mutez, p.callback) + } with (list [op], s) + ] + + function main (const gen__parameters1 : action * storage) + : list (operation) * storage is + case gen__parameters1 of [ + (a, s) -> + case a of [ + Transfer (p) -> transfer (p, s) + | Approve (p) -> approve (p, s) + | GetAllowance (p) -> getAllowance (p, s) + | GetBalance (p) -> getBalance (p, s) + | GetTotalSupply (p) -> getTotalSupply (p, s) + ] + ] |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/FA1.2.ligo" ; "cameligo" ] ; + [%expect {| + type tokens = (address, nat) big_map + + type allowances = (address * address, nat) big_map + + type storage = + {total_amount : nat; + tokens : tokens; + allowances : allowances} + + type transfer = + {value : nat; + address_to : address; + address_from : address} + + type approve = {value : nat; spender : address} + + type getAllowance = + {spender : address; + owner : address; + callback : nat contract} + + type getBalance = {owner : address; callback : nat contract} + + type getTotalSupply = {callback : nat contract} + + type action = + Transfer of transfer | GetTotalSupply of getTotalSupply + | GetBalance of getBalance | GetAllowance of getAllowance + | Approve of approve + + let transfer + : transfer * storage -> operation list * storage = + (fun gen__parameters6 : transfer * storage -> + match gen__parameters6 with + p : transfer, s : storage -> + let new_allowances : allowances = Big_map.empty in + let gen__env9 = {new_allowances = new_allowances} in + let gen__env9 = + if (EQ (Tezos.sender) (p.address_from)) + then + let new_allowances = s.allowances in + let gen__env9 = + {gen__env9 with + {new_allowances = new_allowances}} in + begin + (); + gen__env9 + end + else + let authorized_value : nat = + match (Map.find_opt + (Tezos.sender, p.address_from) + (s.allowances)) + with + Some value -> value + | None -> 0n in + let gen__env8 = + {new_allowances = new_allowances} in + let gen__env8 = + if (LT (authorized_value) (p.value)) + then + begin + (failwith ("Not Enough Allowance")); + gen__env8 + end + else + let new_allowances = + (Map.update + (Tezos.sender, p.address_from) + ((Some + ((abs + ((SUB + (authorized_value) + (p.value))))))) + (s.allowances)) in + let gen__env8 = + {gen__env8 with + {new_allowances = new_allowances}} in + begin + (); + gen__env8 + end in + let new_allowances = gen__env8.new_allowances in + let gen__env9 = + {gen__env9 with + {new_allowances = new_allowances}} in + begin + (); + gen__env9 + end in + let new_allowances = gen__env9.new_allowances in + let sender_balance : nat = + match (Map.find_opt (p.address_from) (s.tokens)) + with + Some value -> value + | None -> 0n in + let new_tokens : tokens = Big_map.empty in + let gen__env12 = {new_tokens = new_tokens} in + let gen__env12 = + if (LT (sender_balance) (p.value)) + then + begin + (failwith ("Not Enough Balance")); + gen__env12 + end + else + let new_tokens = + (Map.update + (p.address_from) + ((Some + ((abs + ((SUB (sender_balance) (p.value))))))) + (s.tokens)) in + let gen__env12 = + {gen__env12 with + {new_tokens = new_tokens}} in + let receiver_balance : nat = + match (Map.find_opt (p.address_to) (s.tokens)) + with + Some value -> value + | None -> 0n in + let new_tokens = + (Map.update + (p.address_to) + ((Some + ((ADD (receiver_balance) (p.value))))) + (new_tokens)) in + let gen__env12 = + {gen__env12 with + {new_tokens = new_tokens}} in + begin + (); + gen__env12 + end in + let new_tokens = gen__env12.new_tokens in + ([] : operation list), + {s with + {allowances = new_allowances; + tokens = new_tokens}}) + + let approve : approve * storage -> operation list * storage = + (fun gen__parameters5 : approve * storage -> + match gen__parameters5 with + p : approve, s : storage -> + let previous_value : nat = + match (Map.find_opt + (p.spender, Tezos.sender) + (s.allowances)) + with + Some value -> value + | None -> 0n in + let new_allowances : allowances = Big_map.empty in + let gen__env14 = {new_allowances = new_allowances} in + let gen__env14 = + if (AND + ((GT (previous_value) (0n))) + ((GT (p.value) (0n)))) + then + begin + (failwith ("Unsafe Allowance Change")); + gen__env14 + end + else + let new_allowances = + (Map.update + (p.spender, Tezos.sender) + ((Some (p.value))) + (s.allowances)) in + let gen__env14 = + {gen__env14 with + {new_allowances = new_allowances}} in + begin + (); + gen__env14 + end in + let new_allowances = gen__env14.new_allowances in + ([] : operation list), + {s with + {allowances = new_allowances}}) + + let getAllowance + : getAllowance * storage -> operation list * storage = + (fun gen__parameters4 : getAllowance * storage -> + match gen__parameters4 with + p : getAllowance, s : storage -> + let value : nat = + match (Map.find_opt + (p.owner, p.spender) + (s.allowances)) + with + Some value -> value + | None -> 0n in + let op : operation = + (Tezos.transaction (value) (0mutez) (p.callback)) in + [op], s) + + let getBalance + : getBalance * storage -> operation list * storage = + (fun gen__parameters3 : getBalance * storage -> + match gen__parameters3 with + p : getBalance, s : storage -> + let value : nat = + match (Map.find_opt (p.owner) (s.tokens)) with + Some value -> value + | None -> 0n in + let op : operation = + (Tezos.transaction (value) (0mutez) (p.callback)) in + [op], s) + + let getTotalSupply + : getTotalSupply * storage -> operation list * storage = + (fun gen__parameters2 : getTotalSupply * storage -> + match gen__parameters2 with + p : getTotalSupply, s : storage -> + let total : nat = s.total_amount in + let op : operation = + (Tezos.transaction (total) (0mutez) (p.callback)) in + [op], s) + + let main : action * storage -> operation list * storage = + (fun gen__parameters1 : action * storage -> + match gen__parameters1 with + a : action, s : storage -> + match a with + Transfer p -> transfer p s + | Approve p -> approve p s + | GetAllowance p -> getAllowance p s + | GetBalance p -> getBalance p s + | GetTotalSupply p -> getTotalSupply p s) |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/FA1.2.ligo" ; "reasonligo" ] ; + [%expect {| + type tokens = big_map(address, nat); + + type allowances = big_map((address, address), nat); + + type storage = {total_amount: nat, tokens, allowances }; + + type transfer = { + value: nat, + address_to: address, + address_from: address + }; + + type approve = {value: nat, spender: address }; + + type getAllowance = { + spender: address, + owner: address, + callback: contract(nat) + }; + + type getBalance = {owner: address, callback: contract(nat) }; + + type getTotalSupply = {callback: contract(nat) }; + + type action = + Transfer(transfer) + | GetTotalSupply(getTotalSupply) + | GetBalance(getBalance) + | GetAllowance(getAllowance) + | Approve(approve); + + let transfer + : ((transfer, storage)) => (list(operation), storage) = + ((gen__parameters6: (transfer, storage)) => + switch(gen__parameters6) { + | (p: transfer, s: storage) => + let new_allowances: allowances = Big_map.empty; + let gen__env9 = { + new_allowances: new_allowances + }; + let gen__env9 = + if ((EQ((Tezos.sender), (p.address_from)))) { + + let new_allowances = s.allowances; + let gen__env9 = + {...gen__env9, + {new_allowances: new_allowances }}; + begin + (); + gen__env9 + end + } else { + + let authorized_value: nat = + switch(( + Map.find_opt(((Tezos.sender, p.address_from)), + (s.allowances)))) { + | Somevalue => value + | None => 0n + }; + let gen__env8 = { + new_allowances: new_allowances + }; + let gen__env8 = + if ((LT((authorized_value), (p.value)))) { + + begin + (failwith(("Not Enough Allowance"))); + gen__env8 + end + } else { + + let new_allowances = + ( + Map.update(((Tezos.sender, + p.address_from)), + (( + Some((( + abs((( + SUB((authorized_value), + (p.value)))))))))), + (s.allowances))); + let gen__env8 = + {...gen__env8, + {new_allowances: new_allowances }}; + begin + (); + gen__env8 + end + }; + let new_allowances = gen__env8.new_allowances; + let gen__env9 = + {...gen__env9, + {new_allowances: new_allowances }}; + begin + (); + gen__env9 + end + }; + let new_allowances = gen__env9.new_allowances; + let sender_balance: nat = + switch(( + Map.find_opt((p.address_from), (s.tokens)))) { + | Somevalue => value + | None => 0n + }; + let new_tokens: tokens = Big_map.empty; + let gen__env12 = { + new_tokens: new_tokens + }; + let gen__env12 = + if ((LT((sender_balance), (p.value)))) { + + begin + (failwith(("Not Enough Balance"))); + gen__env12 + end + } else { + + let new_tokens = + ( + Map.update((p.address_from), + (( + Some((( + abs((( + SUB((sender_balance), (p.value)))))))))), + (s.tokens))); + let gen__env12 = + {...gen__env12, + {new_tokens: new_tokens }}; + let receiver_balance: nat = + switch(( + Map.find_opt((p.address_to), (s.tokens)))) { + | Somevalue => value + | None => 0n + }; + let new_tokens = + ( + Map.update((p.address_to), + (( + Some((( + ADD((receiver_balance), (p.value))))))), + (new_tokens))); + let gen__env12 = + {...gen__env12, + {new_tokens: new_tokens }}; + begin + (); + gen__env12 + end + }; + let new_tokens = gen__env12.new_tokens; + ([] : list(operation), + {...s, + { + allowances: new_allowances, + tokens: new_tokens + }}) + }); + + let approve + : ((approve, storage)) => (list(operation), storage) = + ((gen__parameters5: (approve, storage)) => + switch(gen__parameters5) { + | (p: approve, s: storage) => + let previous_value: nat = + switch(( + Map.find_opt(((p.spender, Tezos.sender)), + (s.allowances)))) { + | Somevalue => value + | None => 0n + }; + let new_allowances: allowances = Big_map.empty; + let gen__env14 = { + new_allowances: new_allowances + }; + let gen__env14 = + if (( + AND(((GT((previous_value), (0n)))), + ((GT((p.value), (0n))))))) { + + begin + (failwith(("Unsafe Allowance Change"))); + gen__env14 + end + } else { + + let new_allowances = + ( + Map.update(((p.spender, Tezos.sender)), + ((Some((p.value)))), + (s.allowances))); + let gen__env14 = + {...gen__env14, + {new_allowances: new_allowances }}; + begin + (); + gen__env14 + end + }; + let new_allowances = gen__env14.new_allowances; + ([] : list(operation), + {...s, + {allowances: new_allowances }}) + }); + + let getAllowance + : ((getAllowance, storage)) => (list(operation), storage) = + ((gen__parameters4: (getAllowance, storage)) => + switch(gen__parameters4) { + | (p: getAllowance, s: storage) => + let value: nat = + switch(( + Map.find_opt(((p.owner, p.spender)), + (s.allowances)))) { + | Somevalue => value + | None => 0n + }; + let op: operation = + ( + Tezos.transaction((value), + (0mutez), + (p.callback))); + ([op], s) + }); + + let getBalance + : ((getBalance, storage)) => (list(operation), storage) = + ((gen__parameters3: (getBalance, storage)) => + switch(gen__parameters3) { + | (p: getBalance, s: storage) => + let value: nat = + switch((Map.find_opt((p.owner), (s.tokens)))) { + | Somevalue => value + | None => 0n + }; + let op: operation = + ( + Tezos.transaction((value), + (0mutez), + (p.callback))); + ([op], s) + }); + + let getTotalSupply + : ((getTotalSupply, storage)) => (list(operation), storage) = + ((gen__parameters2: (getTotalSupply, storage)) => + switch(gen__parameters2) { + | (p: getTotalSupply, s: storage) => + let total: nat = s.total_amount; + let op: operation = + ( + Tezos.transaction((total), + (0mutez), + (p.callback))); + ([op], s) + }); + + let main + : ((action, storage)) => (list(operation), storage) = + ((gen__parameters1: (action, storage)) => + switch(gen__parameters1) { + | (a: action, s: storage) => + switch(a) { + | Transfer p => transfer(p, s) + | Approve p => approve(p, s) + | GetAllowance p => getAllowance(p, s) + | GetBalance p => getBalance(p, s) + | GetTotalSupply p => getTotalSupply(p, s) + } + }); |}] + +let%expect_test _ = + run_ligo_good [ "transpile-contract" ; "../../test/contracts/failwith.ligo" ; "pascaligo" ] ; + [%expect {| + type parameter is Zero of nat | Pos of nat + + type storage is unit + + type return is list (operation) * storage + + function main (const gen__parameters1 : parameter * storage) + : return is + case gen__parameters1 of [ + (p, s) -> + block { + case p of [ + Zero (n) -> + if GT (n, 0n) then failwith ("fail") else skip + | Pos (n) -> + if GT (n, 0n) then skip else failwith ("fail") + ] + } with ((list [] : list (operation)), s) + ] + + function foobar (const i : int) : int is + block { + const p : parameter = (Zero (42n)); + const gen__env7 = record [i = i]; + const gen__env7 + = if GT (i, 0) + then + block { + const i = ADD (i, 1); + gen__env7.i := i; + const gen__env5 = record [i = i]; + const gen__env5 + = if GT (i, 10) + then + block { + const i = 20; + gen__env5.i := i; + failwith ("who knows"); + const i = 30; + gen__env5.i := i; + skip + } with gen__env5 + else + block { + skip + } with gen__env5; + const i = gen__env5.i; + gen__env7.i := i; + skip + } with gen__env7 + else + block { + case p of [ + Zero (n) -> failwith (42n) + | Pos (n) -> skip + ] + } with gen__env7; + const i = gen__env7.i + } with + case p of [ + Zero (n) -> i + | Pos (n) -> (failwith ("waaaa") : int) + ] + + function failer (const p : int) : int is + block { + if EQ (p, 1) then failwith (42) else skip + } with p |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/failwith.ligo" ; "cameligo" ] ; + [%expect {| + type parameter = Zero of nat | Pos of nat + + type storage = unit + + type return = operation list * storage + + let main : parameter * storage -> return = + (fun gen__parameters1 : parameter * storage -> + match gen__parameters1 with + p : parameter, s : storage -> + begin + match p with + Zero n -> + if (GT (n) (0n)) + then (failwith ("fail")) + else () + | Pos n -> + if (GT (n) (0n)) + then () + else (failwith ("fail")); + ([] : operation list), s + end) + + let foobar : int -> int = + (fun i : int -> + let p : parameter = (Zero 42n) in + let gen__env7 = {i = i} in + let gen__env7 = + if (GT (i) (0)) + then + let i = (ADD (i) (1)) in + let gen__env7 = {gen__env7 with {i = i}} in + let gen__env5 = {i = i} in + let gen__env5 = + if (GT (i) (10)) + then + let i = 20 in + let gen__env5 = {gen__env5 with {i = i}} in + begin + (failwith ("who knows")); + let i = 30 in + let gen__env5 = {gen__env5 with {i = i}} in + begin + (); + gen__env5 + end + end + else + begin + (); + gen__env5 + end in + let i = gen__env5.i in + let gen__env7 = {gen__env7 with {i = i}} in + begin + (); + gen__env7 + end + else + begin + match p with + Zero n -> (failwith (42n)) + | Pos n -> (); + gen__env7 + end in + let i = gen__env7.i in + match p with + Zero n -> i + | Pos n -> ((failwith ("waaaa")) : int)) + + let failer : int -> int = + (fun p : int -> + begin + if (EQ (p) (1)) then (failwith (42)) else (); + p + end) |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/failwith.ligo" ; "reasonligo" ] ; + [%expect {| + type parameter = Zero(nat) | Pos(nat); + + type storage = unit; + + type return = (list(operation), storage); + + let main: ((parameter, storage)) => return = + ((gen__parameters1: (parameter, storage)) => + switch(gen__parameters1) { + | (p: parameter, s: storage) => + begin + switch(p) { + | Zero n => + if ((GT((n), (0n)))) { + (failwith(("fail"))) + } else { + () + } + | Pos n => + if ((GT((n), (0n)))) { + () + } else { + (failwith(("fail"))) + } + }; + ([] : list(operation), s) + end + }); + + let foobar: int => int = + ((i: int) => + let p: parameter = (Zero 42n); + let gen__env7 = { + i: i + }; + let gen__env7 = + if ((GT((i), (0)))) { + + let i = (ADD((i), (1))); + let gen__env7 = {...gen__env7, {i: i }}; + let gen__env5 = { + i: i + }; + let gen__env5 = + if ((GT((i), (10)))) { + + let i = 20; + let gen__env5 = {...gen__env5, {i: i }}; + begin + (failwith(("who knows"))); + let i = 30; + let gen__env5 = {...gen__env5, {i: i }}; + begin + (); + gen__env5 + end + end + } else { + + begin + (); + gen__env5 + end + }; + let i = gen__env5.i; + let gen__env7 = {...gen__env7, {i: i }}; + begin + (); + gen__env7 + end + } else { + + begin + switch(p) { + | Zero n => (failwith((42n))) + | Pos n => () + }; + gen__env7 + end + }; + let i = gen__env7.i; + switch(p) { + | Zero n => i + | Pos n => (failwith(("waaaa"))) : int + }); + + let failer: int => int = + ((p: int) => begin + if ((EQ((p), (1)))) { + (failwith((42))) + } else { + () + }; + p + end); |}] + +let%expect_test _ = + run_ligo_good [ "transpile-contract" ; "../../test/contracts/recursion.ligo" ; "pascaligo" ] ; + [%expect {| + recursive function sum (const gen__parameters2 : int * int) + : int is + case gen__parameters2 of [ + (n, acc) -> + if LT (n, 1) + then acc + else sum (SUB (n, 1), ADD (acc, n)) + ] + + recursive + function fibo + (const gen__parameters1 : int * int * int) : int is + case gen__parameters1 of [ + (n, n_1, n_0) -> + if LT (n, 2) + then n_1 + else fibo (SUB (n, 1), ADD (n_1, n_0), n_1) + ] |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/recursion.ligo" ; "cameligo" ] ; + [%expect {| + let rec sum : int * int -> int = + (fun gen__parameters2 : int * int -> + match gen__parameters2 with + n : int, acc : int -> + if (LT (n) (1)) + then acc + else sum (SUB (n) (1)) (ADD (acc) (n))) + + let rec fibo : int * int * int -> int = + (fun gen__parameters1 : int * int * int -> + match gen__parameters1 with + n : int, n_1 : int, n_0 : int -> + if (LT (n) (2)) + then n_1 + else fibo (SUB (n) (1)) (ADD (n_1) (n_0)) n_1) |}]; + run_ligo_good [ "transpile-contract" ; "../../test/contracts/recursion.ligo" ; "reasonligo" ] ; + [%expect {| + let rec sum: ((int, int)) => int = + ((gen__parameters2: (int, int)) => + switch(gen__parameters2) { + | (n: int, acc: int) => + if ((LT((n), (1)))) { + acc + } else { + sum((SUB((n), (1))), (ADD((acc), (n)))) + } + }); + + let rec fibo: ((int, int, int)) => int = + ((gen__parameters1: (int, int, int)) => + switch(gen__parameters1) { + | (n: int, n_1: int, n_0: int) => + if ((LT((n), (2)))) { + n_1 + } else { + fibo((SUB((n), (1))), (ADD((n_1), (n_0))), n_1) + } + }); |}] diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 1e88176da..d7ab83cee 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -18,97 +18,97 @@ let syntax_to_variant (Syntax_name syntax) source = | _ -> fail (invalid_syntax syntax) -let parsify_pascaligo source = +let parse_and_abstract_pascaligo source = let%bind raw = trace parser_tracer @@ Parser.Pascaligo.parse_file source in let%bind imperative = trace cit_pascaligo_tracer @@ Tree_abstraction.Pascaligo.compile_program raw in ok imperative -let parsify_expression_pascaligo source = +let parse_and_abstract_expression_pascaligo source = let%bind raw = trace parser_tracer @@ Parser.Pascaligo.parse_expression source in let%bind imperative = trace cit_pascaligo_tracer @@ Tree_abstraction.Pascaligo.compile_expression raw in ok imperative -let parsify_cameligo source = +let parse_and_abstract_cameligo source = let%bind raw = trace parser_tracer @@ Parser.Cameligo.parse_file source in let%bind imperative = trace cit_cameligo_tracer @@ Tree_abstraction.Cameligo.compile_program raw in ok imperative -let parsify_expression_cameligo source = +let parse_and_abstract_expression_cameligo source = let%bind raw = trace parser_tracer @@ Parser.Cameligo.parse_expression source in let%bind imperative = trace cit_cameligo_tracer @@ Tree_abstraction.Cameligo.compile_expression raw in ok imperative -let parsify_reasonligo source = +let parse_and_abstract_reasonligo source = let%bind raw = trace parser_tracer @@ Parser.Reasonligo.parse_file source in let%bind imperative = trace cit_cameligo_tracer @@ Tree_abstraction.Cameligo.compile_program raw in ok imperative -let parsify_expression_reasonligo source = +let parse_and_abstract_expression_reasonligo source = let%bind raw = trace parser_tracer @@ Parser.Reasonligo.parse_expression source in let%bind imperative = trace cit_cameligo_tracer @@ Tree_abstraction.Cameligo.compile_expression raw in ok imperative -let parsify syntax source : (Ast_imperative.program, _) Trace.result = - let%bind parsify = +let parse_and_abstract syntax source : (Ast_imperative.program, _) Trace.result = + let%bind parse_and_abstract = match syntax with - PascaLIGO -> ok parsify_pascaligo - | CameLIGO -> ok parsify_cameligo - | ReasonLIGO -> ok parsify_reasonligo in - let%bind parsified = parsify source in + PascaLIGO -> ok parse_and_abstract_pascaligo + | CameLIGO -> ok parse_and_abstract_cameligo + | ReasonLIGO -> ok parse_and_abstract_reasonligo in + let%bind parsified = parse_and_abstract source in let%bind applied = trace self_ast_imperative_tracer @@ Self_ast_imperative.all_program parsified in ok applied -let parsify_expression syntax source = - let%bind parsify = match syntax with - PascaLIGO -> ok parsify_expression_pascaligo - | CameLIGO -> ok parsify_expression_cameligo - | ReasonLIGO -> ok parsify_expression_reasonligo in - let%bind parsified = parsify source in +let parse_and_abstract_expression syntax source = + let%bind parse_and_abstract = match syntax with + PascaLIGO -> ok parse_and_abstract_expression_pascaligo + | CameLIGO -> ok parse_and_abstract_expression_cameligo + | ReasonLIGO -> ok parse_and_abstract_expression_reasonligo in + let%bind parsified = parse_and_abstract source in let%bind applied = trace self_ast_imperative_tracer @@ Self_ast_imperative.all_expression parsified in ok applied -let parsify_string_reasonligo source = +let parse_and_abstract_string_reasonligo source = let%bind raw = trace parser_tracer @@ Parser.Reasonligo.parse_string source in let%bind imperative = trace cit_cameligo_tracer @@ Tree_abstraction.Cameligo.compile_program raw in ok imperative -let parsify_string_pascaligo source = +let parse_and_abstract_string_pascaligo source = let%bind raw = trace parser_tracer @@ Parser.Pascaligo.parse_string source in let%bind imperative = trace cit_pascaligo_tracer @@ Tree_abstraction.Pascaligo.compile_program raw in ok imperative -let parsify_string_cameligo source = +let parse_and_abstract_string_cameligo source = let%bind raw = trace parser_tracer @@ Parser.Cameligo.parse_string source in let%bind imperative = trace cit_cameligo_tracer @@ Tree_abstraction.Cameligo.compile_program raw in ok imperative -let parsify_string syntax source = - let%bind parsify = +let parse_and_abstract_string syntax source = + let%bind parse_and_abstract = match syntax with - PascaLIGO -> ok parsify_string_pascaligo - | CameLIGO -> ok parsify_string_cameligo - | ReasonLIGO -> ok parsify_string_reasonligo in - let%bind parsified = parsify source in + PascaLIGO -> ok parse_and_abstract_string_pascaligo + | CameLIGO -> ok parse_and_abstract_string_cameligo + | ReasonLIGO -> ok parse_and_abstract_string_reasonligo in + let%bind parsified = parse_and_abstract source in let%bind applied = trace self_ast_imperative_tracer @@ Self_ast_imperative.all_program parsified in ok applied diff --git a/src/main/compile/of_core.ml b/src/main/compile/of_core.ml index 8f580f153..e7fb6511f 100644 --- a/src/main/compile/of_core.ml +++ b/src/main/compile/of_core.ml @@ -24,10 +24,12 @@ let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result = let name = Var.of_name entry_point in let entry_point_var : Ast_core.expression = - { expression_content = Ast_core.E_variable name ; + { content = Ast_core.E_variable name ; + sugar = None ; location = Virtual "generated entry-point variable" } in let applied : Ast_core.expression = - { expression_content = Ast_core.E_application {lamb=entry_point_var; args=param} ; + { content = Ast_core.E_application {lamb=entry_point_var; args=param} ; + sugar = None ; location = Virtual "generated application" } in ok applied diff --git a/src/main/compile/of_imperative.ml b/src/main/compile/of_imperative.ml index 269b994ad..eb60d2fdd 100644 --- a/src/main/compile/of_imperative.ml +++ b/src/main/compile/of_imperative.ml @@ -3,10 +3,6 @@ open Trace open Ast_imperative open Purification -type form = - | Contract of string - | Env - let compile (program : program) : (Ast_sugar.program, _) result = trace purification_tracer @@ compile_program program diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index c04cdb970..fedd52399 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -3,16 +3,16 @@ open Helpers let compile (source_filename:string) syntax : (Ast_imperative.program , _) result = let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind abstract = parsify syntax source_filename in + let%bind abstract = parse_and_abstract syntax source_filename in ok abstract let compile_string (source:string) syntax : (Ast_imperative.program , _) result = - let%bind abstract = parsify_string syntax source in + let%bind abstract = parse_and_abstract_string syntax source in ok abstract let compile_expression : v_syntax -> string -> (Ast_imperative.expression , _) result = fun syntax exp -> - parsify_expression syntax exp + parse_and_abstract_expression syntax exp let compile_contract_input : string -> string -> v_syntax -> (Ast_imperative.expression , _) result = fun storage parameter syntax -> @@ -26,4 +26,4 @@ let preprocess source_filename syntax = Helpers.preprocess syntax source_filename let pretty_print source_filename syntax = - Helpers.pretty_print syntax source_filename \ No newline at end of file + Helpers.pretty_print syntax source_filename diff --git a/src/main/compile/of_sugar.ml b/src/main/compile/of_sugar.ml index 1a3da165d..b35b70d41 100644 --- a/src/main/compile/of_sugar.ml +++ b/src/main/compile/of_sugar.ml @@ -3,10 +3,6 @@ open Ast_sugar open Desugaring open Main_errors -type form = - | Contract of string - | Env - let compile (program : program) : (Ast_core.program , _) result = trace desugaring_tracer @@ compile_program program diff --git a/src/main/uncompile/dune b/src/main/decompile/dune similarity index 54% rename from src/main/uncompile/dune rename to src/main/decompile/dune index d453c4495..8789ef69b 100644 --- a/src/main/uncompile/dune +++ b/src/main/decompile/dune @@ -1,17 +1,30 @@ (library - (name uncompile) - (public_name ligo.uncompile) + (name decompile) + (public_name ligo.decompile) (libraries + main_errors simple-utils + tezos-utils + parser + tree_abstraction + ast_imperative + self_ast_imperative purification + ast_sugar + self_ast_sugar desugaring + ast_core + self_ast_core typer_new typer ast_typed + self_ast_typed + interpreter spilling mini_c + self_mini_c stacking - main_errors + self_michelson ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/main/uncompile/formatter.ml b/src/main/decompile/formatter.ml similarity index 100% rename from src/main/uncompile/formatter.ml rename to src/main/decompile/formatter.ml diff --git a/src/main/decompile/helpers.ml b/src/main/decompile/helpers.ml new file mode 100644 index 000000000..18d152326 --- /dev/null +++ b/src/main/decompile/helpers.ml @@ -0,0 +1,78 @@ +open Trace +open Main_errors + +type s_syntax = Syntax_name of string +type v_syntax = PascaLIGO | CameLIGO | ReasonLIGO + +let syntax_to_variant (Syntax_name syntax) source = + match syntax, source with + "auto", Some sf -> + (match Filename.extension sf with + ".ligo" | ".pligo" -> ok PascaLIGO + | ".mligo" -> ok CameLIGO + | ".religo" -> ok ReasonLIGO + | ext -> fail (syntax_auto_detection ext)) + | ("pascaligo" | "PascaLIGO"), _ -> ok PascaLIGO + | ("cameligo" | "CameLIGO"), _ -> ok CameLIGO + | ("reasonligo" | "ReasonLIGO"), _ -> ok ReasonLIGO + | _ -> fail (invalid_syntax syntax) + +let specialise_and_print_pascaligo program = + let%bind cst = trace cit_pascaligo_tracer @@ + Tree_abstraction.Pascaligo.decompile_program program in + let%bind source = trace pretty_tracer @@ + Parser.Pascaligo.pretty_print cst + in ok source + +let specialise_and_print_expression_pascaligo expression = + let%bind cst = trace cit_pascaligo_tracer @@ + Tree_abstraction.Pascaligo.decompile_expression expression in + let%bind source = trace pretty_tracer @@ + Parser.Pascaligo.pretty_print_expression cst + in ok source + +let specialise_and_print_cameligo program = + let%bind cst = trace cit_cameligo_tracer @@ + Tree_abstraction.Cameligo.decompile_program program in + let%bind source = trace pretty_tracer @@ + Parser.Cameligo.pretty_print cst + in ok source + +let specialise_and_print_expression_cameligo expression = + let%bind cst = trace cit_cameligo_tracer @@ + Tree_abstraction.Cameligo.decompile_expression expression in + let%bind source = trace pretty_tracer @@ + Parser.Cameligo.pretty_print_expression cst + in ok source + +let specialise_and_print_reasonligo program = + let%bind cst = trace cit_cameligo_tracer @@ + Tree_abstraction.Cameligo.decompile_program program in + let%bind source = trace pretty_tracer @@ + Parser.Reasonligo.pretty_print cst + in ok source + +let specialise_and_print_expression_reasonligo expression = + let%bind cst = trace cit_cameligo_tracer @@ + Tree_abstraction.Cameligo.decompile_expression expression in + let%bind source = trace pretty_tracer @@ + Parser.Reasonligo.pretty_print_expression cst + in ok source + + +let specialise_and_print syntax source : (Buffer.t, _) Trace.result = + let%bind specialise_and_print = + match syntax with + PascaLIGO -> ok specialise_and_print_pascaligo + | CameLIGO -> ok specialise_and_print_cameligo + | ReasonLIGO -> ok specialise_and_print_reasonligo in + let%bind source = specialise_and_print source in + ok source + +let specialise_and_print_expression syntax source = + let%bind specialise_and_print = match syntax with + PascaLIGO -> ok specialise_and_print_expression_pascaligo + | CameLIGO -> ok specialise_and_print_expression_cameligo + | ReasonLIGO -> ok specialise_and_print_expression_reasonligo in + let%bind source = specialise_and_print source in + ok source diff --git a/src/main/decompile/of_core.ml b/src/main/decompile/of_core.ml new file mode 100644 index 000000000..2aec5f093 --- /dev/null +++ b/src/main/decompile/of_core.ml @@ -0,0 +1,10 @@ +open Trace +open Ast_core +open Desugaring +open Main_errors + +let decompile (program : program) : (Ast_sugar.program , _) result = + trace sugaring_tracer @@ decompile_program program + +let decompile_expression (e : expression) : (Ast_sugar.expression , _) result = + trace sugaring_tracer @@ decompile_expression e diff --git a/src/main/decompile/of_imperative.ml b/src/main/decompile/of_imperative.ml new file mode 100644 index 000000000..0be5fa967 --- /dev/null +++ b/src/main/decompile/of_imperative.ml @@ -0,0 +1,10 @@ +open Trace +open Ast_imperative +open Helpers + +let decompile (program : program) syntax : (_ , _) result = + let%bind syntax = syntax_to_variant syntax None in + specialise_and_print syntax program + +let decompile_expression (e : expression) syntax : (_ , _) result = + specialise_and_print_expression syntax e diff --git a/src/main/uncompile/uncompile.ml b/src/main/decompile/of_michelson.ml similarity index 54% rename from src/main/uncompile/uncompile.ml rename to src/main/decompile/of_michelson.ml index 8d2dccfd1..886fe95a5 100644 --- a/src/main/uncompile/uncompile.ml +++ b/src/main/decompile/of_michelson.ml @@ -5,7 +5,7 @@ open Trace open Simple_utils.Runned_result type ret_type = Function | Expression -let uncompile_value func_or_expr program entry ex_ty_value = +let decompile_value func_or_expr program entry ex_ty_value = let%bind output_type = let%bind entry_expression = trace_option entrypoint_not_found @@ Ast_typed.get_entry program entry in match func_or_expr with @@ -14,30 +14,30 @@ let uncompile_value func_or_expr program entry ex_ty_value = | Function -> let%bind (_,output_type) = trace_option entrypoint_not_a_function @@ Ast_typed.get_t_function entry_expression.type_expression in ok output_type in - let%bind mini_c = trace uncompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in - let%bind typed = trace uncompile_mini_c @@ Spilling.decompile mini_c output_type in - let%bind core = trace uncompile_typed @@ Typer.untype_expression typed in + let%bind mini_c = trace decompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in + let%bind typed = trace decompile_mini_c @@ Spilling.decompile mini_c output_type in + let%bind core = trace decompile_typed @@ Typer.untype_expression typed in ok @@ core -let uncompile_typed_program_entry_expression_result program entry runned_result = +let decompile_typed_program_entry_expression_result program entry runned_result = match runned_result with | Fail s -> ok (Fail s) | Success ex_ty_value -> - let%bind uncompiled_value = uncompile_value Expression program entry ex_ty_value in - ok (Success uncompiled_value) + let%bind decompiled_value = decompile_value Expression program entry ex_ty_value in + ok (Success decompiled_value) -let uncompile_typed_program_entry_function_result program entry runned_result = +let decompile_typed_program_entry_function_result program entry runned_result = match runned_result with | Fail s -> ok (Fail s) | Success ex_ty_value -> - let%bind uncompiled_value = uncompile_value Function program entry ex_ty_value in - ok (Success uncompiled_value) + let%bind decompiled_value = decompile_value Function program entry ex_ty_value in + ok (Success decompiled_value) -let uncompile_expression type_value runned_result = +let decompile_expression type_value runned_result = match runned_result with | Fail s -> ok (Fail s) | Success ex_ty_value -> - let%bind mini_c = trace uncompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in - let%bind typed = trace uncompile_mini_c @@ Spilling.decompile mini_c type_value in - let%bind uncompiled_value = trace uncompile_typed @@ Typer.untype_expression typed in - ok (Success uncompiled_value) + let%bind mini_c = trace decompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in + let%bind typed = trace decompile_mini_c @@ Spilling.decompile mini_c type_value in + let%bind decompiled_value = trace decompile_typed @@ Typer.untype_expression typed in + ok (Success decompiled_value) diff --git a/src/main/decompile/of_sugar.ml b/src/main/decompile/of_sugar.ml new file mode 100644 index 000000000..d4677d87d --- /dev/null +++ b/src/main/decompile/of_sugar.ml @@ -0,0 +1,10 @@ +open Trace +open Ast_sugar +open Purification +open Main_errors + +let decompile (program : program) : (Ast_imperative.program , _) result = + trace depurification_tracer @@ decompile_program program + +let decompile_expression (e : expression) : (Ast_imperative.expression , _) result = + trace depurification_tracer @@ decompile_expression e diff --git a/src/main/dune b/src/main/dune index b68862611..5fa7eb0aa 100644 --- a/src/main/dune +++ b/src/main/dune @@ -4,7 +4,7 @@ (libraries run compile - uncompile + decompile main_errors ) (preprocess diff --git a/src/main/main.ml b/src/main/main.ml index b2b366512..efdc7e6f2 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -1,5 +1,5 @@ module Run = Run -module Compile = Compile -module Uncompile = Uncompile +module Compile = Compile +module Decompile = Decompile module Display = Display module Formatter = Main_errors.Formatter diff --git a/src/main/main_errors/formatter.ml b/src/main/main_errors/formatter.ml index 0d325c6d2..f928f1bd6 100644 --- a/src/main/main_errors/formatter.ml +++ b/src/main/main_errors/formatter.ml @@ -121,9 +121,12 @@ let rec error_ppformat' : display_format:string display_format -> | `Main_michelson_execution_error _ -> Format.fprintf f "@[Error of execution@]" | `Main_parser e -> Parser.Errors.error_ppformat ~display_format f e + | `Main_pretty _e -> () (*no error in this pass*) | `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_ppformat ~display_format f e | `Main_purification e -> Purification.Errors.error_ppformat ~display_format f e + | `Main_depurification _e -> () (*no error in this pass*) | `Main_desugaring _e -> () (*no error in this pass*) + | `Main_sugaring _e -> () (*no error in this pass*) | `Main_cit_pascaligo e -> Tree_abstraction.Pascaligo.Errors.error_ppformat ~display_format f e | `Main_cit_cameligo e -> Tree_abstraction.Cameligo.Errors.error_ppformat ~display_format f e | `Main_typer e -> Typer.Errors.error_ppformat ~display_format f e @@ -133,9 +136,9 @@ let rec error_ppformat' : display_format:string display_format -> | `Main_spilling e -> Spilling.Errors.error_ppformat ~display_format f e | `Main_stacking e -> Stacking.Errors.error_ppformat ~display_format f e - | `Main_uncompile_michelson e -> Stacking.Errors.error_ppformat ~display_format f e - | `Main_uncompile_mini_c e -> Spilling.Errors.error_ppformat ~display_format f e - | `Main_uncompile_typed e -> Typer.Errors.error_ppformat ~display_format f e + | `Main_decompile_michelson e -> Stacking.Errors.error_ppformat ~display_format f e + | `Main_decompile_mini_c e -> Spilling.Errors.error_ppformat ~display_format f e + | `Main_decompile_typed e -> Typer.Errors.error_ppformat ~display_format f e ) let error_ppformat : display_format:string display_format -> @@ -272,9 +275,12 @@ let rec error_jsonformat : Types.all -> J.t = fun a -> | `Main_entrypoint_not_found -> json_error ~stage:"top-level glue" ~content:(`String "Missing entrypoint") | `Main_parser e -> Parser.Errors.error_jsonformat e + | `Main_pretty _ -> `Null (*no error in this pass*) | `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_jsonformat e | `Main_purification e -> Purification.Errors.error_jsonformat e + | `Main_depurification _ -> `Null (*no error in this pass*) | `Main_desugaring _ -> `Null (*no error in this pass*) + | `Main_sugaring _ -> `Null (*no error in this pass*) | `Main_cit_pascaligo e -> Tree_abstraction.Pascaligo.Errors.error_jsonformat e | `Main_cit_cameligo e -> Tree_abstraction.Cameligo.Errors.error_jsonformat e | `Main_typer e -> Typer.Errors.error_jsonformat e @@ -284,9 +290,9 @@ let rec error_jsonformat : Types.all -> J.t = fun a -> | `Main_self_mini_c e -> Self_mini_c.Errors.error_jsonformat e | `Main_stacking e -> Stacking.Errors.error_jsonformat e - | `Main_uncompile_michelson e -> Stacking.Errors.error_jsonformat e - | `Main_uncompile_mini_c e -> Spilling.Errors.error_jsonformat e - | `Main_uncompile_typed e -> Typer.Errors.error_jsonformat e + | `Main_decompile_michelson e -> Stacking.Errors.error_jsonformat e + | `Main_decompile_mini_c e -> Spilling.Errors.error_jsonformat e + | `Main_decompile_typed e -> Typer.Errors.error_jsonformat e let error_format : _ Display.format = { pp = error_ppformat; diff --git a/src/main/main_errors/main_errors.ml b/src/main/main_errors/main_errors.ml index d701f64b2..fbdcd6a41 100644 --- a/src/main/main_errors/main_errors.ml +++ b/src/main/main_errors/main_errors.ml @@ -5,11 +5,14 @@ type all = Types.all (* passes tracers *) let parser_tracer (e:Parser.Errors.parser_error) : all = `Main_parser e +let pretty_tracer (e:Parser.Errors.parser_error) : all = `Main_pretty e let cit_cameligo_tracer (e:Tree_abstraction.Cameligo.Errors.abs_error) : all = `Main_cit_cameligo e let cit_pascaligo_tracer (e:Tree_abstraction.Pascaligo.Errors.abs_error) : all = `Main_cit_pascaligo e let self_ast_imperative_tracer (e:Self_ast_imperative.Errors.self_ast_imperative_error) : all = `Main_self_ast_imperative e let purification_tracer (e:Purification.Errors.purification_error) : all = `Main_purification e +let depurification_tracer (e:Purification.Errors.purification_error) : all = `Main_depurification e let desugaring_tracer (e:Desugaring.Errors.desugaring_error) : all = `Main_desugaring e +let sugaring_tracer (e:Desugaring.Errors.desugaring_error) : all = `Main_sugaring e let typer_tracer (e:Typer.Errors.typer_error) : all = `Main_typer e let self_ast_typed_tracer (e:Self_ast_typed.Errors.self_ast_typed_error) : all = `Main_self_ast_typed e let self_mini_c_tracer (e:Self_mini_c.Errors.self_mini_c_error) : all = `Main_self_mini_c e @@ -17,9 +20,9 @@ let spilling_tracer (e:Spilling.Errors.spilling_error) : all = `Main_spilling e let stacking_tracer (e:Stacking.Errors.stacking_error) : all = `Main_stacking e let interpret_tracer (e:Interpreter.interpreter_error) : all = `Main_interpreter e -let uncompile_mini_c : Spilling.Errors.spilling_error -> all = fun e -> `Main_uncompile_mini_c e -let uncompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_uncompile_typed e -let uncompile_michelson : Stacking.Errors.stacking_error -> all = fun e -> `Main_uncompile_michelson e +let decompile_mini_c : Spilling.Errors.spilling_error -> all = fun e -> `Main_decompile_mini_c e +let decompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_decompile_typed e +let decompile_michelson : Stacking.Errors.stacking_error -> all = fun e -> `Main_decompile_michelson e (* top-level glue (in between passes) *) diff --git a/src/main/main_errors/types.ml b/src/main/main_errors/types.ml index b0f5c3a4a..7526ecae1 100644 --- a/src/main/main_errors/types.ml +++ b/src/main/main_errors/types.ml @@ -21,9 +21,12 @@ type all = | `Main_michelson_execution_error of Proto_alpha_utils.Trace.tezos_alpha_error list | `Main_parser of Parser.Errors.parser_error + | `Main_pretty of Parser.Errors.parser_error | `Main_self_ast_imperative of Self_ast_imperative.Errors.self_ast_imperative_error - | `Main_purification of Purification.Errors.purification_error + | `Main_purification of Purification.Errors.purification_error + | `Main_depurification of Purification.Errors.purification_error | `Main_desugaring of Desugaring.Errors.desugaring_error + | `Main_sugaring of Desugaring.Errors.desugaring_error | `Main_cit_pascaligo of Tree_abstraction.Pascaligo.Errors.abs_error | `Main_cit_cameligo of Tree_abstraction.Cameligo.Errors.abs_error | `Main_typer of Typer.Errors.typer_error @@ -33,9 +36,9 @@ type all = | `Main_spilling of Spilling.Errors.spilling_error | `Main_stacking of Stacking.Errors.stacking_error - | `Main_uncompile_michelson of Stacking.Errors.stacking_error - | `Main_uncompile_mini_c of Spilling.Errors.spilling_error - | `Main_uncompile_typed of Typer.Errors.typer_error + | `Main_decompile_michelson of Stacking.Errors.stacking_error + | `Main_decompile_mini_c of Spilling.Errors.spilling_error + | `Main_decompile_typed of Typer.Errors.typer_error | `Main_entrypoint_not_a_function | `Main_entrypoint_not_found | `Main_invalid_amount of string diff --git a/src/passes/01-parsing/cameligo.ml b/src/passes/01-parsing/cameligo.ml index 69af2bd6e..9332b8a34 100644 --- a/src/passes/01-parsing/cameligo.ml +++ b/src/passes/01-parsing/cameligo.ml @@ -145,15 +145,28 @@ let preprocess source = apply (fun () -> Unit.preprocess source) (* Pretty-print a file (after parsing it). *) -let pretty_print source = +let pretty_print cst = + let doc = Pretty.print cst in + let buffer = Buffer.create 131 in + let width = + match Terminal_size.get_columns () with + None -> 60 + | Some c -> c in + let () = PPrint.ToBuffer.pretty 1.0 width buffer doc + in Trace.ok buffer + +let pretty_print_from_source source = match parse_file source with Stdlib.Error _ as e -> e - | Ok ast -> - let doc = Pretty.print (fst ast) in - let buffer = Buffer.create 131 in - let width = - match Terminal_size.get_columns () with - None -> 60 - | Some c -> c in - let () = PPrint.ToBuffer.pretty 1.0 width buffer doc - in Trace.ok buffer + | Ok cst -> + pretty_print @@ fst cst + +let pretty_print_expression cst = + let doc = Pretty.pp_expr cst in + let buffer = Buffer.create 131 in + let width = + match Terminal_size.get_columns () with + None -> 60 + | Some c -> c in + let () = PPrint.ToBuffer.pretty 1.0 width buffer doc + in Trace.ok buffer diff --git a/src/passes/01-parsing/cameligo.mli b/src/passes/01-parsing/cameligo.mli index 01151dca8..6268b9ebc 100644 --- a/src/passes/01-parsing/cameligo.mli +++ b/src/passes/01-parsing/cameligo.mli @@ -22,4 +22,9 @@ val parse_expression : string -> (CST.expr , Errors.parser_error) result val preprocess : string -> (Buffer.t , Errors.parser_error) result (** Pretty-print a given CameLIGO file (after parsing it). *) -val pretty_print : string -> (Buffer.t, Errors.parser_error) result +val pretty_print_from_source : string -> (Buffer.t, Errors.parser_error) result + +(** Take a CameLIGO cst and pretty_print it *) +val pretty_print : CST.t -> (Buffer.t, _) result + +val pretty_print_expression : CST.expr -> (Buffer.t, _) result diff --git a/src/passes/01-parsing/cameligo/Parser.mly b/src/passes/01-parsing/cameligo/Parser.mly index de0251a89..015a5b2f2 100644 --- a/src/passes/01-parsing/cameligo/Parser.mly +++ b/src/passes/01-parsing/cameligo/Parser.mly @@ -93,7 +93,7 @@ tuple(item): list__(item): "[" sep_or_term_list(item,";")? "]" { - let compound = Brackets ($1,$3) + let compound = Some (Brackets ($1,$3)) and region = cover $1 $3 in let elements, terminator = match $2 with @@ -194,7 +194,7 @@ record_type: let () = Utils.nsepseq_to_list ne_elements |> Scoping.check_fields in let region = cover $1 $3 - and value = {compound = Braces ($1,$3); ne_elements; terminator} + and value = {compound = Some (Braces ($1,$3)); ne_elements; terminator} in TRecord {region; value} } field_decl: @@ -300,7 +300,7 @@ record_pattern: "{" sep_or_term_list(field_pattern,";") "}" { let ne_elements, terminator = $2 in let region = cover $1 $3 in - let value = {compound = Braces ($1,$3); ne_elements; terminator} + let value = {compound = Some (Braces ($1,$3)); ne_elements; terminator} in {region; value} } field_pattern: @@ -377,22 +377,18 @@ if_then_else(right_expr): test = $2; kwd_then = $3; ifso = $4; - kwd_else = $5; - ifnot = $6} + ifnot = Some($5,$6)} in ECond {region; value} } if_then(right_expr): "if" expr "then" right_expr { - let the_unit = ghost, ghost in - let ifnot = EUnit (wrap_ghost the_unit) in let stop = expr_to_region $4 in let region = cover $1 stop in let value = {kwd_if = $1; test = $2; kwd_then = $3; ifso = $4; - kwd_else = ghost; - ifnot} + ifnot = None} in ECond {region; value} } base_if_then_else__open(x): @@ -630,7 +626,7 @@ record_expr: "{" sep_or_term_list(field_assignment,";") "}" { let ne_elements, terminator = $2 in let region = cover $1 $3 in - let value = {compound = Braces ($1,$3); + let value = {compound = Some (Braces ($1,$3)); ne_elements; terminator} in {region; value} } @@ -643,7 +639,7 @@ update_record: lbrace = $1; record = $2; kwd_with = $3; - updates = {value = {compound = Braces (ghost, ghost); + updates = {value = {compound = None; ne_elements; terminator}; region = cover $3 $5}; @@ -671,7 +667,7 @@ path : sequence: "begin" series? "end" { let region = cover $1 $3 - and compound = BeginEnd ($1,$3) in + and compound = Some (BeginEnd ($1,$3)) in let elements = $2 in let value = {compound; elements; terminator=None} in {region; value} } @@ -691,7 +687,7 @@ let_in_sequence: let seq = $6 in let stop = nsepseq_to_region expr_to_region seq in let region = cover $1 stop in - let compound = BeginEnd (Region.ghost, Region.ghost) in + let compound = None in let elements = Some seq in let value = {compound; elements; terminator=None} in let body = ESeq {region; value} in diff --git a/src/passes/01-parsing/cameligo/Pretty.ml b/src/passes/01-parsing/cameligo/Pretty.ml index 1eec2dc69..cfe384a0e 100644 --- a/src/passes/01-parsing/cameligo/Pretty.ml +++ b/src/passes/01-parsing/cameligo/Pretty.ml @@ -173,13 +173,15 @@ and pp_clause {value; _} = pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs) and pp_cond_expr {value; _} = - let {test; ifso; kwd_else; ifnot; _} = value in + let {test; ifso; ifnot; _} = value in let test = string "if " ^^ group (nest 3 (pp_expr test)) and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso)) - and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) - in if kwd_else#is_ghost - then test ^/^ ifso - else test ^/^ ifso ^/^ ifnot + in match ifnot with + Some (_,ifnot) -> + let ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) in + test ^/^ ifso ^/^ ifnot + | None -> + test ^/^ ifso and pp_annot_expr {value; _} = let expr, _, type_expr = value.inside in @@ -243,18 +245,15 @@ and pp_injection : let sep = string ";" ^^ break 1 in let elements = Utils.sepseq_to_list elements in let elements = separate_map sep printer elements in - match pp_compound compound with + match Option.map pp_compound compound with None -> elements | Some (opening, closing) -> string opening ^^ nest 1 elements ^^ string closing and pp_compound = function - BeginEnd (start, _) -> - if start#is_ghost then None else Some ("begin","end") -| Braces (start, _) -> - if start#is_ghost then None else Some ("{","}") -| Brackets (start, _) -> - if start#is_ghost then None else Some ("[","]") + BeginEnd (_, _) -> ("begin","end") +| Braces (_, _) -> ("{","}") +| Brackets (_, _) -> ("[","]") and pp_constr_expr = function ENone _ -> string "None" @@ -282,7 +281,7 @@ and pp_ne_injection : fun printer {value; _} -> let {compound; ne_elements; _} = value in let elements = pp_nsepseq ";" printer ne_elements in - match pp_compound compound with + match Option.map pp_compound compound with None -> elements | Some (opening, closing) -> string opening ^^ nest 1 elements ^^ string closing @@ -356,8 +355,8 @@ and pp_let_in {value; _} = | Some _ -> "let rec " in let binding = pp_let_binding binding and attr = pp_attributes attributes - in string let_str ^^ binding ^^ attr - ^^ hardline ^^ group (string "in " ^^ nest 3 (pp_expr body)) + in string let_str ^^ binding ^^ attr ^^ string " in" + ^^ hardline ^^ group (pp_expr body) and pp_fun {value; _} = let {binders; lhs_type; body; _} = value in @@ -375,7 +374,7 @@ and pp_seq {value; _} = let sep = string ";" ^^ hardline in let elements = Utils.sepseq_to_list elements in let elements = separate_map sep pp_expr elements in - match pp_compound compound with + match Option.map pp_compound compound with None -> elements | Some (opening, closing) -> string opening @@ -406,7 +405,7 @@ and pp_variants {value; _} = let head = pp_variant head in let head = if tail = [] then head else ifflat head (blank 2 ^^ head) in let rest = List.map snd tail in - let app variant = break 1 ^^ string "| " ^^ pp_variant variant + let app variant = group (break 1 ^^ string "| " ^^ pp_variant variant) in head ^^ concat_map app rest and pp_variant {value; _} = diff --git a/src/passes/01-parsing/pascaligo.ml b/src/passes/01-parsing/pascaligo.ml index 2f79b07e2..15564e207 100644 --- a/src/passes/01-parsing/pascaligo.ml +++ b/src/passes/01-parsing/pascaligo.ml @@ -5,6 +5,7 @@ module Scoping = Parser_pascaligo.Scoping module Region = Simple_utils.Region module ParErr = Parser_pascaligo.ParErr module SSet = Set.Make (String) +module Pretty = Parser_pascaligo.Pretty (* Mock IOs TODO: Fill them with CLI options *) @@ -153,3 +154,23 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source) (* Preprocessing a contract in a file *) let preprocess source = apply (fun () -> Unit.preprocess source) + +let pretty_print cst = + let doc = Pretty.print cst in + let buffer = Buffer.create 131 in + let width = + match Terminal_size.get_columns () with + None -> 60 + | Some c -> c in + let () = PPrint.ToBuffer.pretty 1.0 width buffer doc + in Trace.ok buffer + +let pretty_print_expression cst = + let doc = Pretty.pp_expr cst in + let buffer = Buffer.create 131 in + let width = + match Terminal_size.get_columns () with + None -> 60 + | Some c -> c in + let () = PPrint.ToBuffer.pretty 1.0 width buffer doc + in Trace.ok buffer diff --git a/src/passes/01-parsing/pascaligo.mli b/src/passes/01-parsing/pascaligo.mli index 1711f7974..a3edee391 100644 --- a/src/passes/01-parsing/pascaligo.mli +++ b/src/passes/01-parsing/pascaligo.mli @@ -21,3 +21,8 @@ val parse_expression : string -> (CST.expr, parser_error) result (** Preprocess a given PascaLIGO file and preprocess it. *) val preprocess : string -> (Buffer.t, parser_error) result + +(** Take a PascaLIGO cst and pretty_print it *) +val pretty_print : CST.t -> (Buffer.t, _) result + +val pretty_print_expression : CST.expr -> (Buffer.t, _) result diff --git a/src/passes/01-parsing/pascaligo/Parser.mly b/src/passes/01-parsing/pascaligo/Parser.mly index 33eaf3149..287e3c750 100644 --- a/src/passes/01-parsing/pascaligo/Parser.mly +++ b/src/passes/01-parsing/pascaligo/Parser.mly @@ -255,23 +255,6 @@ fun_expr: open_fun_decl: ioption ("recursive") "function" fun_name parameters type_expr_colon? "is" - block "with" expr { - Scoping.check_reserved_name $3; - let stop = expr_to_region $9 in - let region = cover $2 stop - and value = {kwd_recursive= $1; - kwd_function = $2; - fun_name = $3; - param = $4; - ret_type = $5; - kwd_is = $6; - block_with = Some ($7, $8); - return = $9; - terminator = None; - attributes = None} - in {region; value} - } -| ioption ("recursive") "function" fun_name parameters type_expr_colon? "is" expr { Scoping.check_reserved_name $3; let stop = expr_to_region $7 in @@ -282,11 +265,11 @@ open_fun_decl: param = $4; ret_type = $5; kwd_is = $6; - block_with = None; return = $7; terminator = None; attributes = None} - in {region; value} } + in {region; value} + } fun_decl: open_fun_decl ";"? { @@ -588,7 +571,7 @@ case_clause(rhs): assignment: lhs ":=" rhs { - let stop = rhs_to_region $3 in + let stop = expr_to_region $3 in let region = cover (lhs_to_region $1) stop and value = {lhs = $1; assign = $2; rhs = $3} in {region; value} } @@ -665,6 +648,20 @@ expr: | cond_expr { $1 } | disj_expr { $1 } | fun_expr { EFun $1 } +| block_with { EBlock $1 } + +block_with : + block "with" expr { + let start = $2 + and stop = expr_to_region $3 in + let region = cover start stop in + let value : CST.block_with = { + block = $1; + kwd_with = $2; + expr = $3; + } + in {value;region} + } cond_expr: "if" expr "then" expr ";"? "else" expr { diff --git a/src/passes/01-parsing/pascaligo/Pretty.ml b/src/passes/01-parsing/pascaligo/Pretty.ml index d7de34d37..e6a7a6c3b 100644 --- a/src/passes/01-parsing/pascaligo/Pretty.ml +++ b/src/passes/01-parsing/pascaligo/Pretty.ml @@ -81,7 +81,7 @@ and pp_variants {value; _} = let head = if tail = [] then head else ifflat head (string " " ^^ head) in let rest = List.map snd tail in - let app variant = break 1 ^^ string "| " ^^ pp_variant variant + let app variant = group (break 1 ^^ string "| " ^^ pp_variant variant) in head ^^ concat_map app rest and pp_variant {value; _} = @@ -136,7 +136,7 @@ and pp_fun_expr {value; _} = and pp_fun_decl {value; _} = let {kwd_recursive; fun_name; param; - ret_type; block_with; return; attributes; _} = value in + ret_type; return; attributes; _} = value in let start = match kwd_recursive with None -> string "function" @@ -145,10 +145,9 @@ and pp_fun_decl {value; _} = let parameters = pp_par pp_parameters param in let expr = pp_expr return in let body = - match block_with with - None -> group (nest 2 (break 1 ^^ expr)) - | Some (b,_) -> hardline ^^ pp_block b ^^ string " with" - ^^ group (nest 4 (break 1 ^^ expr)) + match return with + EBlock _ -> group (break 1 ^^ expr) + | _ -> group (nest 2 (break 1 ^^ expr)) and attr = match attributes with None -> empty @@ -379,6 +378,14 @@ and pp_expr = function | EPar e -> pp_par pp_expr e | EFun e -> pp_fun_expr e | ECodeInj e -> pp_code_inj e +| EBlock e -> pp_block_with e + +and pp_block_with {value; _} = + let {block;kwd_with; expr;_} = value in + let expr = value.expr in + let expr = pp_expr expr in + group(pp_block block ^^ string " with" + ^^ group (nest 4 (break 1 ^^ expr))) and pp_annot_expr {value; _} = let expr, _, type_expr = value.inside in diff --git a/src/passes/01-parsing/pascaligo/error.messages.checked-in b/src/passes/01-parsing/pascaligo/error.messages.checked-in index cdc032911..4a5dc1b33 100644 --- a/src/passes/01-parsing/pascaligo/error.messages.checked-in +++ b/src/passes/01-parsing/pascaligo/error.messages.checked-in @@ -4147,30 +4147,6 @@ contract: Function With -contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is Begin Skip End While -## -## Ends in an error in state: 582. -## -## open_fun_decl -> Recursive Function Ident parameters COLON type_expr Is block . With expr [ Type SEMI Recursive RBRACE Function End EOF Const Attributes ] -## -## The known suffix of the stack is as follows: -## Recursive Function Ident parameters COLON type_expr Is block -## - - - -contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is Begin Skip End With With -## -## Ends in an error in state: 583. -## -## open_fun_decl -> Recursive Function Ident parameters COLON type_expr Is block With . expr [ Type SEMI Recursive RBRACE Function End EOF Const Attributes ] -## -## The known suffix of the stack is as follows: -## Recursive Function Ident parameters COLON type_expr Is block With -## - - - contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is With ## ## Ends in an error in state: 89. diff --git a/src/passes/01-parsing/reasonligo.ml b/src/passes/01-parsing/reasonligo.ml index 5bbed6c0c..777203b98 100644 --- a/src/passes/01-parsing/reasonligo.ml +++ b/src/passes/01-parsing/reasonligo.ml @@ -146,16 +146,29 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source) let preprocess source = apply (fun () -> Unit.preprocess source) (* Pretty-print a file (after parsing it). *) +let pretty_print cst = + let doc = Pretty.print cst in + let buffer = Buffer.create 131 in + let width = + match Terminal_size.get_columns () with + None -> 60 + | Some c -> c in + let () = PPrint.ToBuffer.pretty 1.0 width buffer doc + in Trace.ok buffer -let pretty_print source = +let pretty_print_from_source source = match parse_file source with Stdlib.Error _ as e -> e - | Ok ast -> - let doc = Pretty.print (fst ast) in - let buffer = Buffer.create 131 in - let width = - match Terminal_size.get_columns () with - None -> 60 - | Some c -> c in - let () = PPrint.ToBuffer.pretty 1.0 width buffer doc - in Trace.ok buffer + | Ok cst -> + pretty_print @@ fst cst + + +let pretty_print_expression cst = + let doc = Pretty.pp_expr cst in + let buffer = Buffer.create 131 in + let width = + match Terminal_size.get_columns () with + None -> 60 + | Some c -> c in + let () = PPrint.ToBuffer.pretty 1.0 width buffer doc + in Trace.ok buffer diff --git a/src/passes/01-parsing/reasonligo.mli b/src/passes/01-parsing/reasonligo.mli index 4a032807a..866bd9b1a 100644 --- a/src/passes/01-parsing/reasonligo.mli +++ b/src/passes/01-parsing/reasonligo.mli @@ -21,5 +21,10 @@ val parse_expression : string -> (CST.expr , Errors.parser_error) result (** Preprocess a given ReasonLIGO file and preprocess it. *) val preprocess : string -> (Buffer.t , Errors.parser_error) result -(** Pretty-print a given CameLIGO file (after parsing it). *) -val pretty_print : string -> (Buffer.t , Errors.parser_error) result +(** Pretty-print a given ReasonLIGO file (after parsing it). *) +val pretty_print_from_source : string -> (Buffer.t , Errors.parser_error) result + +(** Take a ReasonLIGO cst and pretty_print it *) +val pretty_print : CST.t -> (Buffer.t, _) result + +val pretty_print_expression : CST.expr -> (Buffer.t, _) result diff --git a/src/passes/01-parsing/reasonligo/Parser.mly b/src/passes/01-parsing/reasonligo/Parser.mly index 3e931a5e9..ec7436836 100644 --- a/src/passes/01-parsing/reasonligo/Parser.mly +++ b/src/passes/01-parsing/reasonligo/Parser.mly @@ -131,7 +131,7 @@ tuple(item): list__(item): "[" sep_or_term_list(item,";")? "]" { - let compound = Brackets ($1,$3) + let compound = Some (Brackets ($1,$3)) and region = cover $1 $3 in let elements, terminator = match $2 with @@ -224,7 +224,7 @@ record_type: let () = Utils.nsepseq_to_list ne_elements |> Scoping.check_fields in let region = cover $1 $3 - and value = {compound = Braces ($1,$3); ne_elements; terminator} + and value = {compound = Some(Braces ($1,$3)); ne_elements; terminator} in TRecord {region; value} } type_expr_field: @@ -362,7 +362,7 @@ record_pattern: "{" sep_or_term_list(field_pattern,",") "}" { let ne_elements, terminator = $2 in let region = cover $1 $3 in - let value = {compound = Braces ($1,$3); + let value = {compound = Some (Braces ($1,$3)); ne_elements; terminator} in {region; value} } @@ -592,15 +592,12 @@ parenthesized_expr: if_then(right_expr): "if" parenthesized_expr "{" closed_if ";"? "}" { - let the_unit = ghost, ghost in - let ifnot = EUnit {region=ghost; value=the_unit} in let region = cover $1 $6 in let value = {kwd_if = $1; test = $2; kwd_then = $3; ifso = $4; - kwd_else = ghost; - ifnot} + ifnot = None} in ECond {region; value} } if_then_else(right_expr): @@ -611,8 +608,7 @@ if_then_else(right_expr): test = $2; kwd_then = $3; ifso = $4; - kwd_else = $6; - ifnot = $9} + ifnot = Some ($6,$9)} in ECond {region; value} } base_if_then_else__open(x): @@ -825,7 +821,7 @@ list_or_spread: let elts, terminator = $4 in let elts = Utils.nsepseq_cons $2 $3 elts in let value = { - compound = Brackets ($1,$5); + compound = Some (Brackets ($1,$5)); elements = Some elts; terminator} and region = cover $1 $5 in @@ -837,7 +833,7 @@ list_or_spread: in EList (ECons {region; value}) } | "[" expr? "]" { - let compound = Brackets ($1,$3) + let compound = Some (Brackets ($1,$3)) and elements = match $2 with None -> None @@ -913,7 +909,7 @@ update_record: lbrace = $1; record = $3; kwd_with = $4; - updates = {value = {compound = Braces (ghost, ghost); + updates = {value = {compound = None; ne_elements; terminator}; region = cover $4 $6}; @@ -949,7 +945,7 @@ exprs: in let sequence = ESeq { value = { - compound = BeginEnd (ghost, ghost); + compound = None; elements = Some val_; terminator = snd c}; region = sequence_region @@ -982,7 +978,7 @@ more_field_assignments: sequence: "{" exprs "}" { let elts, _region = $2 in - let compound = Braces ($1, $3) in + let compound = Some (Braces ($1, $3)) in let value = {compound; elements = Some elts; terminator = None} in @@ -991,7 +987,7 @@ sequence: record: "{" field_assignment more_field_assignments? "}" { - let compound = Braces ($1,$4) in + let compound = Some (Braces ($1,$4)) in let region = cover $1 $4 in match $3 with @@ -1010,7 +1006,7 @@ record: let field_name = {$2 with value} in let comma, elts = $3 in let ne_elements = Utils.nsepseq_cons field_name comma elts in - let compound = Braces ($1,$4) in + let compound = Some (Braces ($1,$4)) in let region = cover $1 $4 in {value = {compound; ne_elements; terminator = None}; region} } diff --git a/src/passes/01-parsing/reasonligo/Pretty.ml b/src/passes/01-parsing/reasonligo/Pretty.ml index 4c507a5d2..597fa713f 100644 --- a/src/passes/01-parsing/reasonligo/Pretty.ml +++ b/src/passes/01-parsing/reasonligo/Pretty.ml @@ -179,13 +179,13 @@ and pp_clause {value; _} = prefix 4 1 (pp_pattern pattern ^^ string " =>") (pp_expr rhs) and pp_cond_expr {value; _} = - let {test; ifso; kwd_else; ifnot; _} = value in + let {test; ifso; ifnot; _} = value in let if_then = string "if" ^^ string " (" ^^ pp_expr test ^^ string ")" ^^ string " {" ^^ break 0 ^^ group (nest 2 (break 2 ^^ pp_expr ifso)) ^^ hardline ^^ string "}" in - if kwd_else#is_ghost then - if_then - else + match ifnot with + None -> if_then + | Some (_,ifnot) -> if_then ^^ string " else" ^^ string " {" ^^ break 0 ^^ group (nest 2 (break 2 ^^ pp_expr ifnot)) ^^ hardline ^^ string "}" @@ -252,18 +252,15 @@ and pp_injection : let sep = (string ",") ^^ break 1 in let elements = Utils.sepseq_to_list elements in let elements = separate_map sep printer elements in - match pp_compound compound with + match Option.map pp_compound compound with None -> elements | Some (opening, closing) -> string opening ^^ nest 1 elements ^^ string closing and pp_compound = function - BeginEnd (start, _) -> - if start#is_ghost then None else Some ("begin","end") -| Braces (start, _) -> - if start#is_ghost then None else Some ("{","}") -| Brackets (start, _) -> - if start#is_ghost then None else Some ("[","]") + BeginEnd (_, _) -> ("begin","end") +| Braces (_, _) -> ("{","}") +| Brackets (_, _) -> ("[","]") and pp_constr_expr = function ENone _ -> string "None" @@ -291,7 +288,7 @@ and pp_ne_injection : fun printer {value; _} -> let {compound; ne_elements; _} = value in let elements = pp_nsepseq "," printer ne_elements in - match pp_compound compound with + match Option.map pp_compound compound with None -> elements | Some (opening, closing) -> string opening ^^ nest 2 (break 0 ^^ elements) ^^ break 1 ^^ string closing @@ -387,7 +384,7 @@ and pp_seq {value; _} = let sep = string ";" ^^ hardline in let elements = Utils.sepseq_to_list elements in let elements = separate_map sep pp_expr elements in - match pp_compound compound with + match Option.map pp_compound compound with None -> elements | Some (opening, closing) -> string opening diff --git a/src/passes/03-tree_abstraction/cameligo/cameligo.ml b/src/passes/03-tree_abstraction/cameligo/cameligo.ml index 3a1c68ef1..c350780a7 100644 --- a/src/passes/03-tree_abstraction/cameligo/cameligo.ml +++ b/src/passes/03-tree_abstraction/cameligo/cameligo.ml @@ -1,8 +1,12 @@ module CST = Cst.Cameligo module AST = Ast_imperative -module Compiler = Compiler +module Compiler = Compiler +module Decompiler = Decompiler module Errors = Errors let compile_program = Compiler.compile_program let compile_expression = Compiler.compile_expression + +let decompile_program = Decompiler.decompile_program +let decompile_expression = Decompiler.decompile_expression diff --git a/src/passes/03-tree_abstraction/cameligo/cameligo.mli b/src/passes/03-tree_abstraction/cameligo/cameligo.mli index 5f22a30ee..d26871e84 100644 --- a/src/passes/03-tree_abstraction/cameligo/cameligo.mli +++ b/src/passes/03-tree_abstraction/cameligo/cameligo.mli @@ -8,5 +8,7 @@ module Errors = Errors val compile_expression : CST.expr -> (AST.expr, Errors.abs_error) result - val compile_program : CST.ast -> (AST.program, Errors.abs_error) result + +val decompile_expression : AST.expr -> (CST.expr, _) result +val decompile_program : AST.program -> (CST.ast, _) result diff --git a/src/passes/03-tree_abstraction/cameligo/compiler.ml b/src/passes/03-tree_abstraction/cameligo/compiler.ml index 5dd691fae..2a50c00e1 100644 --- a/src/passes/03-tree_abstraction/cameligo/compiler.ml +++ b/src/passes/03-tree_abstraction/cameligo/compiler.ml @@ -11,6 +11,7 @@ module Option = Simple_utils.Option open Combinators +let (<@) f g x = f (g x) let nseq_to_list (hd, tl) = hd :: tl let npseq_to_list (hd, tl) = hd :: (List.map snd tl) let npseq_to_nelist (hd, tl) = hd, (List.map snd tl) @@ -247,7 +248,7 @@ in trace (abstracting_expr_tracer t) @@ let%bind ty_opt = bind_map_option (fun (re,te) -> let%bind te = compile_type_expression te in ok(Location.lift re,te)) lhs_type in let%bind rhs = compile_expression let_rhs in - let rhs_b = Var.fresh ~name: "rhs" () in + let rhs_b = Var.fresh ~name:"rhs" () in let rhs',rhs_b_expr = match ty_opt with None -> rhs, e_variable ~loc rhs_b @@ -491,7 +492,8 @@ in trace (abstracting_expr_tracer t) @@ let (c , loc) = r_split c in let%bind expr = compile_expression c.test in let%bind match_true = compile_expression c.ifso in - let%bind match_false = compile_expression c.ifnot in + let%bind match_false = bind_map_option (compile_expression <@ snd) c.ifnot in + let match_false = Option.unopt ~default:(e_unit ()) match_false in return @@ e_cond ~loc expr match_true match_false | ECodeInj ci -> let ci, loc = r_split ci in @@ -541,7 +543,7 @@ and compile_fun lamb' : (expr , abs_error) result = let aux ((var : Raw.variable) , ty_opt) = match var.value , ty_opt with | "storage" , None -> - ok (var , t_variable ~loc @@ Var.fresh ~name:"storage" ()) + ok (var , t_variable_ez ~loc "storage") | _ , None -> fail @@ untyped_fun_param var | _ , Some ty -> ( diff --git a/src/passes/03-tree_abstraction/cameligo/decompiler.ml b/src/passes/03-tree_abstraction/cameligo/decompiler.ml new file mode 100644 index 000000000..3067fdebe --- /dev/null +++ b/src/passes/03-tree_abstraction/cameligo/decompiler.ml @@ -0,0 +1,504 @@ +module AST = Ast_imperative +module CST = Cst.Cameligo +module Predefined = Predefined.Tree_abstraction.Cameligo + +open Trace + +(* General tools *) +let (<@) f g x = f (g x) + +(* Utils *) +let rg = Region.ghost +let wrap : type a. a -> a CST.reg = fun value -> {value;region=rg} +let list_to_sepseq lst = + match lst with + [] -> None + | hd :: lst -> + let aux e = (rg, e) in + Some (hd, List.map aux lst) +let list_to_nsepseq lst = + match list_to_sepseq lst with + Some s -> ok @@ s + | None -> failwith "List is empty" + +let nelist_to_npseq (hd, lst) = (hd, List.map (fun e -> (rg, e)) lst) +let npseq_cons hd lst = hd,(rg, fst lst)::(snd lst) + +let par a = CST.{lpar=rg;inside=a;rpar=rg} +let inject compound a = CST.{compound;elements=a;terminator=Some(rg)} +let ne_inject compound a = CST.{compound;ne_elements=a;terminator=Some(rg)} +let prefix_colon a = (rg, a) +let braces = Some (CST.Braces (rg,rg)) +let brackets = Some (CST.Brackets (rg,rg)) +let beginEnd = Some (CST.BeginEnd (rg,rg)) + +(* Decompiler *) + +let decompile_variable : type a. a Var.t -> CST.variable = fun var -> + let var = Format.asprintf "%a" Var.pp var in + if String.contains var '#' then + let var = String.split_on_char '#' var in + wrap @@ "gen__" ^ (String.concat "" var) + else + if String.length var > 4 && String.equal "gen__" @@ String.sub var 0 5 then + wrap @@ "user__" ^ var + else + wrap @@ var + +let rec decompile_type_expr : AST.type_expression -> _ result = fun te -> + let return te = ok @@ te in + match te.type_content with + T_sum sum -> + let sum = AST.CMap.to_kv_list sum in + let aux (AST.Constructor c, AST.{ctor_type;_}) = + let constr = wrap c in + let%bind arg = decompile_type_expr ctor_type in + let arg = Some (rg, arg) in + let variant : CST.variant = {constr;arg} in + ok @@ wrap variant + in + let%bind sum = bind_map_list aux sum in + let%bind sum = list_to_nsepseq sum in + return @@ CST.TSum (wrap sum) + | T_record record -> + let record = AST.LMap.to_kv_list record in + let aux (AST.Label c, AST.{field_type;_}) = + let field_name = wrap c in + let colon = rg in + let%bind field_type = decompile_type_expr field_type in + let variant : CST.field_decl = {field_name;colon;field_type} in + ok @@ wrap variant + in + let%bind record = bind_map_list aux record in + let%bind record = list_to_nsepseq record in + return @@ CST.TRecord (wrap @@ ne_inject (braces) record) + | T_tuple tuple -> + let%bind tuple = bind_map_list decompile_type_expr tuple in + let%bind tuple = list_to_nsepseq @@ tuple in + return @@ CST.TProd (wrap tuple) + | T_arrow {type1;type2} -> + let%bind type1 = decompile_type_expr type1 in + let%bind type2 = decompile_type_expr type2 in + let arrow = (type1, rg, type2) in + return @@ CST.TFun (wrap arrow) + | T_variable var -> + let var = decompile_variable var in + return @@ CST.TVar (var) + | T_constant const -> + let const = Predefined.type_constant_to_string const in + return @@ CST.TVar (wrap const) + | T_operator (operator, lst) -> + let operator = wrap @@ Predefined.type_operator_to_string operator in + let%bind lst = bind_map_list decompile_type_expr lst in + let%bind lst = list_to_nsepseq lst in + let lst : _ CST.par = {lpar=rg;inside=lst;rpar=rg} in + return @@ CST.TApp (wrap (operator,wrap lst)) + | T_annoted _annot -> + failwith "let's work on it later" + +let get_e_variable : AST.expression -> _ result = fun expr -> + match expr.expression_content with + E_variable var -> ok @@ var + | _ -> failwith @@ + Format.asprintf "%a should be a variable expression" + AST.PP.expression expr + +let get_e_tuple : AST.expression -> _ result = fun expr -> + match expr.expression_content with + E_tuple tuple -> ok @@ tuple + | E_variable _ + | E_literal _ + | E_constant _ + | E_lambda _ -> ok @@ [expr] + | _ -> failwith @@ + Format.asprintf "%a should be a tuple expression" + AST.PP.expression expr + +let pattern_type var ty_opt = + let var = CST.PVar (decompile_variable var) in + match ty_opt with + Some s -> + let%bind type_expr = decompile_type_expr s in + ok @@ CST.PTyped (wrap @@ CST.{pattern=var;colon=rg;type_expr}) + | None -> ok @@ var + +let rec decompile_expression : AST.expression -> _ result = fun expr -> + let return_expr expr = ok @@ expr in + let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in + match expr.expression_content with + E_variable name -> + let var = decompile_variable name in + return_expr @@ CST.EVar (var) + | E_constant {cons_name; arguments} -> + let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in + (match arguments with + [] -> return_expr @@ expr + | _ -> + let%bind arguments = map List.Ne.of_list @@ + map (List.map (fun x -> CST.EPar (wrap @@ par @@ x))) @@ + bind_map_list decompile_expression arguments in + let const = wrap (expr, arguments) in + return_expr_with_par @@ CST.ECall const + ) + | E_literal literal -> + (match literal with + Literal_unit -> return_expr @@ CST.EUnit (wrap (rg,rg)) + | Literal_int i -> return_expr @@ CST.EArith (Int (wrap ("",i))) + | Literal_nat n -> return_expr @@ CST.EArith (Nat (wrap ("",n))) + | Literal_timestamp time -> + let time = Tezos_utils.Time.Protocol.to_notation @@ + Tezos_utils.Time.Protocol.of_seconds @@ Z.to_int64 time in + (* TODO combinators for CSTs. *) + let%bind ty = decompile_type_expr @@ AST.t_timestamp () in + let time = CST.EString (String (wrap time)) in + return_expr @@ CST.EAnnot (wrap @@ par (time, rg, ty)) + | Literal_mutez mtez -> return_expr @@ CST.EArith (Mutez (wrap ("",mtez))) + | Literal_string (Standard str) -> return_expr @@ CST.EString (String (wrap str)) + | Literal_string (Verbatim ver) -> return_expr @@ CST.EString (Verbatim (wrap ver)) + | Literal_bytes b -> + let b = Hex.of_bytes b in + let s = Hex.to_string b in + return_expr @@ CST.EBytes (wrap (s,b)) + | Literal_address addr -> + let addr = CST.EString (String (wrap addr)) in + let%bind ty = decompile_type_expr @@ AST.t_address () in + return_expr @@ CST.EAnnot (wrap @@ par (addr,rg,ty)) + | Literal_signature sign -> + let sign = CST.EString (String (wrap sign)) in + let%bind ty = decompile_type_expr @@ AST.t_signature () in + return_expr @@ CST.EAnnot (wrap @@ par (sign,rg,ty)) + | Literal_key k -> + let k = CST.EString (String (wrap k)) in + let%bind ty = decompile_type_expr @@ AST.t_key () in + return_expr @@ CST.EAnnot (wrap @@ par (k,rg,ty)) + | Literal_key_hash kh -> + let kh = CST.EString (String (wrap kh)) in + let%bind ty = decompile_type_expr @@ AST.t_key_hash () in + return_expr @@ CST.EAnnot (wrap @@ par (kh,rg,ty)) + | Literal_chain_id _ + | Literal_void + | Literal_operation _ -> + failwith "chain_id, void, operation are not created currently ?" + ) + | E_application {lamb;args} -> + let%bind lamb = decompile_expression lamb in + let%bind args = map List.Ne.of_list @@ + bind (bind_map_list decompile_expression) @@ + get_e_tuple args + in + return_expr @@ CST.ECall (wrap (lamb,args)) + | E_lambda lambda -> + let%bind (binders,_lhs_type,_block_with,body) = decompile_lambda lambda in + let fun_expr : CST.fun_expr = {kwd_fun=rg;binders;lhs_type=None;arrow=rg;body} in + return_expr_with_par @@ CST.EFun (wrap @@ fun_expr) + | E_recursive _ -> + failwith "corner case : annonymous recursive function" + | E_let_in {let_binder;rhs;let_result;inline} -> + let var = CST.PVar (decompile_variable @@ fst let_binder) in + let binders = (var,[]) in + let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) @@ snd let_binder in + let%bind let_rhs = decompile_expression rhs in + let binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in + let%bind body = decompile_expression let_result in + let attributes = decompile_attributes inline in + let lin : CST.let_in = {kwd_let=rg;kwd_rec=None;binding;kwd_in=rg;body;attributes} in + return_expr @@ CST.ELetIn (wrap lin) + | E_raw_code {language; code} -> + let language = wrap @@ wrap @@ language in + let%bind code = decompile_expression code in + let ci : CST.code_inj = {language;code;rbracket=rg} in + return_expr @@ CST.ECodeInj (wrap ci) + | E_constructor {constructor;element} -> + let Constructor constr = constructor in + let constr = wrap constr in + let%bind element = decompile_expression element in + return_expr_with_par @@ CST.EConstr (EConstrApp (wrap (constr, Some element))) + | E_matching {matchee; cases} -> + let%bind expr = decompile_expression matchee in + let%bind cases = decompile_matching_cases cases in + let cases : _ CST.case = {kwd_match=rg;expr;kwd_with=rg;lead_vbar=None;cases} in + return_expr @@ CST.ECase (wrap cases) + | E_record record -> + let record = AST.LMap.to_kv_list record in + let aux (AST.Label str, expr) = + let field_name = wrap str in + let%bind field_expr = decompile_expression expr in + let field : CST.field_assign = {field_name;assignment=rg;field_expr} in + ok @@ wrap field + in + let%bind record = bind_map_list aux record in + let%bind record = list_to_nsepseq record in + let record = ne_inject braces record in + (* why is the record not empty ? *) + return_expr @@ CST.ERecord (wrap record) + | E_accessor {record; path} -> + (match List.rev path with + Access_map e :: [] -> + let%bind map = decompile_expression record in + let%bind e = decompile_expression e in + let arg = e,[map] in + return_expr @@ CST.ECall( wrap (CST.EVar (wrap "Map.find_opt"), arg)) + | Access_map e :: lst -> + let path = List.rev lst in + let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in + let%bind struct_name = map (decompile_variable) @@ get_e_variable record in + let proj : CST.projection = {struct_name;selector=rg;field_path} in + let%bind e = decompile_expression e in + let arg = e,[CST.EProj (wrap proj)] in + return_expr @@ CST.ECall( wrap (CST.EVar (wrap "Map.find_opt"), arg)) + | _ -> + let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in + let%bind struct_name = map (decompile_variable) @@ get_e_variable record in + let proj : CST.projection = {struct_name;selector=rg;field_path} in + return_expr @@ CST.EProj (wrap proj) + ) + (* Update on multiple field of the same record. may be removed by adding sugar *) + | E_update {record={expression_content=E_update _;_} as record;path;update} -> + let%bind record = decompile_expression record in + let%bind (record,updates) = match record with + CST.EUpdate {value;_} -> ok @@ (value.record,value.updates) + | _ -> failwith @@ Format.asprintf "Inpossible case %a" AST.PP.expression expr + in + let%bind var,path = match path with + Access_record var::path -> ok @@ (var,path) + | _ -> failwith "Impossible case %a" + in + let%bind field_path = decompile_to_path (Var.of_name var) path in + let%bind field_expr = decompile_expression update in + let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = updates.value.ne_elements in + let updates = wrap @@ ne_inject braces @@ npseq_cons (wrap @@ field_assign) updates in + let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in + return_expr @@ CST.EUpdate (wrap @@ update) + | E_update {record; path; update} -> + let%bind record = map (decompile_variable) @@ get_e_variable record in + let%bind field_expr = decompile_expression update in + let (struct_name,field_path) = List.Ne.of_list path in + (match field_path with + [] -> + (match struct_name with + Access_record name -> + let record : CST.path = Name record in + let field_path = CST.Name (wrap name) in + let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in + let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in + return_expr @@ CST.EUpdate (wrap update) + | Access_tuple i -> + let record : CST.path = Name record in + let field_path = CST.Name (wrap @@ Z.to_string i) in + let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in + let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in + return_expr @@ CST.EUpdate (wrap update) + | Access_map e -> + let%bind e = decompile_expression e in + let arg = field_expr,[e; CST.EVar record] in + return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"), arg)) + ) + | _ -> + let%bind struct_name = match struct_name with + Access_record name -> ok @@ wrap name + | Access_tuple i -> ok @@ wrap @@ Z.to_string i + | Access_map _ -> failwith @@ Format.asprintf "invalid map update %a" AST.PP.expression expr + in + (match List.rev field_path with + Access_map e :: lst -> + let field_path = List.rev lst in + let%bind field_path = bind_map_list decompile_to_selection field_path in + let%bind field_path = list_to_nsepseq field_path in + let field_path : CST.projection = {struct_name; selector=rg;field_path} in + let field_path = CST.EProj (wrap @@ field_path) in + let%bind e = decompile_expression e in + let arg = field_expr, [e; field_path] in + return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"),arg)) + | _ -> + let%bind field_path = bind_map_list decompile_to_selection field_path in + let%bind field_path = list_to_nsepseq field_path in + let field_path : CST.projection = {struct_name; selector=rg;field_path} in + let field_path = CST.Path (wrap @@ field_path) in + let record : CST.path = Name record in + let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in + let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in + return_expr @@ CST.EUpdate (wrap update) + ) + ) + | E_ascription {anno_expr;type_annotation} -> + let%bind expr = decompile_expression anno_expr in + let%bind ty = decompile_type_expr type_annotation in + return_expr @@ CST.EAnnot (wrap @@ par (expr,rg,ty)) + | E_cond {condition;then_clause;else_clause} -> + let%bind test = decompile_expression condition in + let%bind ifso = decompile_expression then_clause in + let%bind ifnot = decompile_expression else_clause in + let ifnot = Some(rg,ifnot) in + let cond : CST.cond_expr = {kwd_if=rg;test;kwd_then=rg;ifso;ifnot} in + return_expr @@ CST.ECond (wrap cond) + | E_sequence {expr1;expr2} -> + let%bind expr1 = decompile_expression expr1 in + let%bind expr2 = decompile_expression expr2 in + return_expr @@ CST.ESeq (wrap @@ inject beginEnd @@ list_to_sepseq [expr1; expr2]) + | E_tuple tuple -> + let%bind tuple = bind_map_list decompile_expression tuple in + let%bind tuple = list_to_nsepseq tuple in + return_expr @@ CST.ETuple (wrap @@ tuple) + | E_map map -> + let%bind map = bind_map_list (bind_map_pair decompile_expression) map in + let aux (k,v) = CST.ETuple (wrap (k,[(rg,v)])) in + let map = List.map aux map in + (match map with + [] -> return_expr @@ CST.EVar (wrap "Big_map.empty") + | _ -> + let var = CST.EVar (wrap "Map.literal") in + return_expr @@ CST.ECall (wrap @@ (var, List.Ne.of_list @@ map)) + ) + | E_big_map big_map -> + let%bind big_map = bind_map_list (bind_map_pair decompile_expression) big_map in + let aux (k,v) = CST.ETuple (wrap (k,[(rg,v)])) in + let big_map = List.map aux big_map in + (match big_map with + [] -> return_expr @@ CST.EVar (wrap "Big_map.empty") + | _ -> + let var = CST.EVar (wrap "Big_map.literal") in + return_expr @@ CST.ECall (wrap @@ (var, List.Ne.of_list @@ big_map)) + ) + | E_list lst -> + let%bind lst = bind_map_list decompile_expression lst in + let lst = list_to_sepseq lst in + return_expr @@ CST.EList (EListComp (wrap @@ inject brackets @@ lst)) + | E_set set -> + let%bind set = bind_map_list decompile_expression set in + let set = List.Ne.of_list @@ set in + let var = CST.EVar (wrap "Set.literal") in + return_expr @@ CST.ECall (wrap @@ (var,set)) + (* We should avoid to generate skip instruction*) + | E_skip -> return_expr @@ CST.EUnit (wrap (rg,rg)) + | E_assign _ + | E_for _ + | E_for_each _ + | E_while _ -> + failwith @@ Format.asprintf "Decompiling a imperative construct to CameLIGO %a" + AST.PP.expression expr + +and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access -> + let struct_name = decompile_variable var in + match access with + [] -> ok @@ CST.Name struct_name + | lst -> + let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection lst in + let path : CST.projection = {struct_name;selector=rg;field_path} in + ok @@ (CST.Path (wrap @@ path) : CST.path) + +and decompile_to_selection : AST.access -> (CST.selection, _) result = fun access -> + match access with + Access_tuple index -> ok @@ CST.Component (wrap @@ ("",index)) + | Access_record str -> ok @@ CST.FieldName (wrap str) + | Access_map _ -> + failwith @@ Format.asprintf + "Can't decompile access_map to selection" + +and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} -> + let%bind param_decl = pattern_type binder input_type in + let param = (param_decl, []) in + let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in + let%bind return = decompile_expression result in + ok @@ (param,ret_type,None,return) + +and decompile_attributes = function + true -> [wrap "inline"] + | false -> [] + +and decompile_matching_cases : AST.matching_expr -> ((CST.expr CST.case_clause Region.reg, Region.t) Parser_shared.Utils.nsepseq Region.reg,_) result = +fun m -> + let%bind cases = match m with + Match_variable (var, ty_opt, expr) -> + let%bind pattern = pattern_type var ty_opt in + let%bind rhs = decompile_expression expr in + let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in + ok @@ [wrap case] + | Match_tuple (lst, ty_opt, expr) -> + let%bind tuple = match ty_opt with + Some ty_lst -> + let aux (var, ty) = + let pattern = CST.PVar (decompile_variable var) in + let%bind type_expr = decompile_type_expr ty in + ok @@ CST.PTyped (wrap @@ CST.{pattern;colon=rg;type_expr}) + in + bind list_to_nsepseq @@ bind_map_list aux @@ List.combine lst ty_lst + | None -> + let aux var = CST.PVar (decompile_variable var) in + list_to_nsepseq @@ List.map aux lst + in + let pattern : CST.pattern = PTuple (wrap @@ tuple) in + let%bind rhs = decompile_expression expr in + let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in + ok @@ [wrap case] + | Match_record _ -> failwith "match_record not availiable yet" + | Match_option {match_none;match_some}-> + let%bind rhs = decompile_expression match_none in + let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in + let%bind rhs = decompile_expression @@ snd match_some in + let var = CST.PVar (decompile_variable @@ fst match_some)in + let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in + ok @@ [wrap some_case;wrap none_case] + | Match_list {match_nil; match_cons} -> + let (hd,tl,expr) = match_cons in + let hd = CST.PVar (decompile_variable hd) in + let tl = CST.PVar (decompile_variable tl) in + let cons = (hd,rg,tl) in + let%bind rhs = decompile_expression @@ expr in + let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in + let%bind rhs = decompile_expression @@ match_nil in + let nil_case : _ CST.case_clause = {pattern=PList (PListComp (wrap @@ inject brackets None));arrow=rg; rhs} in + ok @@ [wrap cons_case; wrap nil_case] + | Match_variant lst -> + let aux ((c,v),e) = + let AST.Constructor c = c in + let constr = wrap @@ c in + let var : CST.pattern = PVar (decompile_variable v) in + let tuple = var in + let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in + let%bind rhs = decompile_expression e in + let case : _ CST.case_clause = {pattern;arrow=rg;rhs} in + ok @@ wrap case + in + bind_map_list aux lst + in + map wrap @@ list_to_nsepseq cases +let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _) result = fun decl -> + let decl = Location.unwrap decl in + let wrap value = ({value;region=Region.ghost} : _ Region.reg) in + match decl with + Declaration_type (name, te) -> + let name = decompile_variable name in + let%bind type_expr = decompile_type_expr te in + ok @@ CST.TypeDecl (wrap (CST.{kwd_type=rg; name; eq=rg; type_expr})) + | Declaration_constant (var, ty_opt, inline, expr) -> + let attributes : CST.attributes = decompile_attributes inline in + let var = CST.PVar (decompile_variable var) in + let binders = (var,[]) in + match expr.expression_content with + E_lambda lambda -> + let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in + let%bind let_rhs = decompile_expression @@ AST.make_e @@ AST.E_lambda lambda in + let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in + let let_decl : CST.let_decl = wrap (rg,None,let_binding,attributes) in + ok @@ CST.Let let_decl + | E_recursive {lambda; _} -> + let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in + let%bind let_rhs = decompile_expression @@ AST.make_e @@ AST.E_lambda lambda in + let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in + let let_decl : CST.let_decl = wrap (rg,Some rg,let_binding,attributes) in + ok @@ CST.Let (let_decl) + | _ -> + let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in + let%bind let_rhs = decompile_expression expr in + let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in + let let_decl : CST.let_decl = wrap (rg,None,let_binding,attributes) in + ok @@ CST.Let let_decl + +let decompile_program : AST.program -> (CST.ast, _) result = fun prg -> + let%bind decl = bind_map_list decompile_declaration prg in + let decl = List.Ne.of_list decl in + ok @@ ({decl;eof=rg}: CST.ast) diff --git a/src/passes/03-tree_abstraction/pascaligo/compiler.ml b/src/passes/03-tree_abstraction/pascaligo/compiler.ml index d3805389d..9bfa6d877 100644 --- a/src/passes/03-tree_abstraction/pascaligo/compiler.ml +++ b/src/passes/03-tree_abstraction/pascaligo/compiler.ml @@ -418,6 +418,11 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e - let (language, _) = r_split language in let%bind code = compile_expression ci.code in return @@ e_raw_code ~loc language code + | EBlock be -> + let be, _ = r_split be in + let%bind next = compile_expression be.expr in + compile_block ~next be.block + and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ = fun compiler cases -> @@ -497,11 +502,11 @@ fun compiler cases -> return @@ AST.Match_variant (List.combine constrs lst) | (p, _), _ -> fail @@ unsupported_pattern_type p -let compile_attribute_declaration = function +and compile_attribute_declaration = function None -> return false | Some _ -> return true -let compile_parameters (params : CST.parameters) = +and compile_parameters (params : CST.parameters) = let compile_param_decl (param : CST.param_decl) = match param with ParamConst pc -> @@ -519,10 +524,10 @@ let compile_parameters (params : CST.parameters) = let params = npseq_to_list params.inside in bind_map_list compile_param_decl params -let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction -> - let return expr = match next with - Some e -> return @@ e_sequence expr e - | None -> return expr +and compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction -> + let return expr = match next with + Some e -> ok @@ e_sequence expr e + | None -> ok @@ expr in let compile_tuple_expression (tuple_expr : CST.tuple_expr) = let (lst, loc) = r_split tuple_expr in @@ -534,7 +539,7 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause -> match if_clause with ClauseInstr i -> compile_instruction ?next i - | ClauseBlock (LongBlock block) -> compile_block ?next block + | ClauseBlock (LongBlock block) -> compile_block ?next block | ClauseBlock (ShortBlock block) -> (* This looks like it should be the job of the parser *) let CST.{lbrace; inside; rbrace} = block.value in @@ -734,16 +739,13 @@ and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun Some block -> return block | None -> fail @@ block_start_with_attribute block -and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) = +and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attributes}: CST.fun_decl) = let%bind attr = compile_attribute_declaration attributes in let (fun_name, loc) = r_split fun_name in let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in let%bind param = compile_parameters param in - let%bind r = compile_expression r in + let%bind result = compile_expression r in let (param, param_type) = List.split param in - let%bind body = Option.unopt ~default:(return r) @@ - Option.map (compile_block ~next:r <@ fst) block_with - in (* This handle the parameter case *) let (lambda,fun_type) = (match param_type with ty::[] -> @@ -751,18 +753,18 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret binder = (Var.of_name @@ List.hd param); input_type = ty ; output_type = ret_type ; - result = body; + result; } in lambda,Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type) | lst -> let lst = Option.bind_list lst in let input_type = Option.map t_tuple lst in - let binder = Var.fresh ~name:"parameter" () in + let binder = Var.fresh ~name:"parameters" () in let lambda : AST.lambda = { binder; input_type = input_type; output_type = ret_type; - result = e_matching_tuple_ez (e_variable binder) param lst body; + result = e_matching_tuple_ez (e_variable binder) param lst result; } in lambda,Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type) ) diff --git a/src/passes/03-tree_abstraction/pascaligo/decompiler.ml b/src/passes/03-tree_abstraction/pascaligo/decompiler.ml new file mode 100644 index 000000000..d273f1160 --- /dev/null +++ b/src/passes/03-tree_abstraction/pascaligo/decompiler.ml @@ -0,0 +1,660 @@ +module AST = Ast_imperative +module CST = Cst.Pascaligo +module Predefined = Predefined.Tree_abstraction.Pascaligo + +open Trace + +(* General tools *) +let (<@) f g x = f (g x) + +(* Utils *) +let rg = Region.ghost +let wrap : type a. a -> a CST.reg = fun value -> {value;region=rg} +let list_to_sepseq lst = + match lst with + [] -> None + | hd :: lst -> + let aux e = (rg, e) in + Some (hd, List.map aux lst) +let list_to_nsepseq lst = + match list_to_sepseq lst with + Some s -> ok @@ s + | None -> failwith "List is not a non_empty list" +let nelist_to_npseq (hd, lst) = (hd, List.map (fun e -> (rg, e)) lst) +let npseq_cons hd lst = hd,(rg, fst lst)::(snd lst) + +let par a = CST.{lpar=rg;inside=a;rpar=rg} +let braces a = CST.{lbrace=rg;inside=a;rbrace=rg} +let brackets a = CST.{lbracket=rg;inside=a;rbracket=rg} +let inject kind a = CST.{kind;enclosing=Brackets (rg,rg);elements=a;terminator=Some(rg)} +let ne_inject kind a = CST.{kind;enclosing=Brackets (rg,rg);ne_elements=a;terminator=Some(rg)} +let prefix_colon a = (rg, a) +let suffix_with a = (a, rg) +let to_block a = CST.{enclosing=Block (rg,rg,rg);statements=a;terminator=Some rg} +let empty_block = to_block (CST.Instr (CST.Skip rg),[]) + +(* Decompiler *) + +let decompile_variable : type a. a Var.t -> CST.variable = fun var -> + let var = Format.asprintf "%a" Var.pp var in + if String.contains var '#' then + let var = String.split_on_char '#' var in + wrap @@ "gen__" ^ (String.concat "" var) + else + if String.length var > 4 && String.equal "gen__" @@ String.sub var 0 5 then + wrap @@ "user__" ^ var + else + wrap @@ var + +let rec decompile_type_expr : AST.type_expression -> _ result = fun te -> + let return te = ok @@ te in + match te.type_content with + T_sum sum -> + let sum = AST.CMap.to_kv_list sum in + let aux (AST.Constructor c, AST.{ctor_type;_}) = + let constr = wrap c in + let%bind arg = decompile_type_expr ctor_type in + let arg = Some (rg, arg) in + let variant : CST.variant = {constr;arg} in + ok @@ wrap variant + in + let%bind sum = bind_map_list aux sum in + let%bind sum = list_to_nsepseq sum in + return @@ CST.TSum (wrap sum) + | T_record record -> + let record = AST.LMap.to_kv_list record in + let aux (AST.Label c, AST.{field_type;_}) = + let field_name = wrap c in + let colon = rg in + let%bind field_type = decompile_type_expr field_type in + let variant : CST.field_decl = {field_name;colon;field_type} in + ok @@ wrap variant + in + let%bind record = bind_map_list aux record in + let%bind record = list_to_nsepseq record in + return @@ CST.TRecord (wrap @@ ne_inject (NEInjRecord rg) record) + | T_tuple tuple -> + let%bind tuple = bind_map_list decompile_type_expr tuple in + let%bind tuple = list_to_nsepseq @@ tuple in + return @@ CST.TProd (wrap tuple) + | T_arrow {type1;type2} -> + let%bind type1 = decompile_type_expr type1 in + let%bind type2 = decompile_type_expr type2 in + let arrow = (type1, rg, type2) in + return @@ CST.TFun (wrap arrow) + | T_variable var -> + let var = decompile_variable var in + return @@ CST.TVar (var) + | T_constant const -> + let const = Predefined.type_constant_to_string const in + return @@ CST.TVar (wrap const) + | T_operator (operator, lst) -> + let operator = wrap @@ Predefined.type_operator_to_string operator in + let%bind lst = bind_map_list decompile_type_expr lst in + let%bind lst = list_to_nsepseq lst in + let lst : _ CST.par = {lpar=rg;inside=lst;rpar=rg} in + return @@ CST.TApp (wrap (operator,wrap lst)) + | T_annoted _annot -> + failwith "let's work on it later" + +let get_e_variable : AST.expression -> _ result = fun expr -> + match expr.expression_content with + E_variable var -> ok @@ var + | _ -> failwith @@ + Format.asprintf "%a should be a variable expression" + AST.PP.expression expr + +let rec get_e_accessor : AST.expression -> _ result = fun expr -> + match expr.expression_content with + E_variable var -> ok @@ (var, []) + | E_accessor {record;path} -> + let%bind (var, lst) = get_e_accessor record in + ok @@ (var, lst @ path) + | _ -> failwith @@ + Format.asprintf "%a should be a variable expression" + AST.PP.expression expr + +let get_e_tuple : AST.expression -> _ result = fun expr -> + match expr.expression_content with + E_tuple tuple -> ok @@ tuple + | E_variable _ + | E_literal _ + | E_constant _ + | E_lambda _ -> ok @@ [expr] + | _ -> failwith @@ + Format.asprintf "%a should be a tuple expression" + AST.PP.expression expr +type eos = +| Expression +| Statements + +type state = Cst_pascaligo.ParserLog.state + +let statements_of_expression : CST.expr -> CST.statement List.Ne.t option = fun stat -> + match stat with + | CST.ECall call -> Some (CST.Instr (CST.ProcCall call), []) + | _ -> None + +let rec decompile_expression : AST.expression -> _ result = fun e -> + let%bind (block,expr) = decompile_to_block e in + match expr with + Some expr -> + ( match block with + Some block -> + let block = wrap @@ block in + ok @@ CST.EBlock (wrap @@ CST.{block;kwd_with=rg;expr}) + | None -> ok @@ expr + ) + | None -> + failwith @@ Format.asprintf + "An expression was expected, but this was decompile to statements. \n + Expr : %a + Loc : %a" + AST.PP.expression e + Location.pp e.location + +and decompile_statements : AST.expression -> _ result = fun expr -> + let%bind (stat,_) = decompile_eos Statements expr in + match stat with + Some stat -> ok @@ stat + | None -> + failwith @@ Format.asprintf + "Statements was expected, but this was decompile to expression. \n + Expr : %a + Loc : %a" + AST.PP.expression expr + Location.pp expr.location + +and decompile_to_block : AST.expression -> _ result = fun expr -> + let to_block a = CST.{enclosing=Block (rg,rg,rg);statements=a;terminator=Some rg} in + let%bind (stats,next) = decompile_eos Expression expr in + let block = Option.map (to_block <@ nelist_to_npseq) stats in + ok @@ (block, next) + +and decompile_to_tuple_expr : AST.expression list -> (CST.tuple_expr,_) result = fun expr -> + let%bind tuple_expr = bind_map_list decompile_expression expr in + let%bind tuple_expr = list_to_nsepseq tuple_expr in + let tuple_expr : CST.tuple_expr = wrap @@ par @@ tuple_expr in + ok @@ tuple_expr + +and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)* (CST.expr option), _) result = fun output expr -> + let return (a,b) = ok @@ (a,b) in + let return_expr expr = return @@ (None, Some expr) in + let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in + let return_stat stat = return @@ (Some stat, None) in + let return_stat_ez stat = return_stat @@ (stat, []) in + let return_inst inst = return_stat_ez @@ CST.Instr inst in + match expr.expression_content with + E_variable name -> + let var = decompile_variable name in + return_expr @@ CST.EVar (var) + | E_constant {cons_name; arguments} -> + let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in + (match arguments with + [] -> return_expr @@ expr + | _ -> + let%bind arguments = decompile_to_tuple_expr arguments in + let const : CST.fun_call = wrap (expr, arguments) in + (match output with + Expression -> return_expr (CST.ECall const) + | Statements -> return_inst (CST.ProcCall const) + ) + ) + | E_literal literal -> + (match literal with + Literal_unit -> return_expr @@ CST.EUnit rg + | Literal_int i -> return_expr @@ CST.EArith (Int (wrap ("",i))) + | Literal_nat n -> return_expr @@ CST.EArith (Nat (wrap ("",n))) + | Literal_timestamp time -> + let time = Tezos_utils.Time.Protocol.to_notation @@ + Tezos_utils.Time.Protocol.of_seconds @@ Z.to_int64 time in + (* TODO combinators for CSTs. *) + let%bind ty = decompile_type_expr @@ AST.t_timestamp () in + let time = CST.EString (String (wrap time)) in + return_expr @@ CST.EAnnot (wrap @@ par (time, rg, ty)) + | Literal_mutez mtez -> return_expr @@ CST.EArith (Mutez (wrap ("",mtez))) + | Literal_string (Standard str) -> return_expr @@ CST.EString (String (wrap str)) + | Literal_string (Verbatim ver) -> return_expr @@ CST.EString (Verbatim (wrap ver)) + | Literal_bytes b -> + let b = Hex.of_bytes b in + let s = Hex.to_string b in + return_expr @@ CST.EBytes (wrap (s,b)) + | Literal_address addr -> + let addr = CST.EString (String (wrap addr)) in + let%bind ty = decompile_type_expr @@ AST.t_address () in + return_expr @@ CST.EAnnot (wrap @@ par (addr,rg,ty)) + | Literal_signature sign -> + let sign = CST.EString (String (wrap sign)) in + let%bind ty = decompile_type_expr @@ AST.t_signature () in + return_expr @@ CST.EAnnot (wrap @@ par (sign,rg,ty)) + | Literal_key k -> + let k = CST.EString (String (wrap k)) in + let%bind ty = decompile_type_expr @@ AST.t_key () in + return_expr @@ CST.EAnnot (wrap @@ par (k,rg,ty)) + | Literal_key_hash kh -> + let kh = CST.EString (String (wrap kh)) in + let%bind ty = decompile_type_expr @@ AST.t_key_hash () in + return_expr @@ CST.EAnnot (wrap @@ par (kh,rg,ty)) + | Literal_chain_id _ + | Literal_void + | Literal_operation _ -> + failwith "chain_id, void, operation are not created currently ?" + ) + | E_application {lamb;args} -> + let%bind lamb = decompile_expression lamb in + let%bind args = bind decompile_to_tuple_expr @@ get_e_tuple args in + (match output with + Expression -> + return_expr @@ CST.ECall (wrap (lamb,args)) + | Statements -> + return_inst @@ CST.ProcCall (wrap (lamb,args)) + ) + | E_lambda lambda -> + let%bind (param,ret_type,return) = decompile_lambda lambda in + let fun_expr : CST.fun_expr = {kwd_function=rg;param;ret_type;kwd_is=rg;return} in + return_expr_with_par @@ CST.EFun (wrap @@ fun_expr) + | E_recursive _ -> + failwith "corner case : annonymous recursive function" + | E_let_in {let_binder;rhs={expression_content=E_update {record={expression_content=E_variable var;_};path;update};_};let_result;inline=_} when Var.equal (fst let_binder) var -> + let%bind lhs = (match List.rev path with + Access_map e :: path -> + let%bind path = decompile_to_path var @@ List.rev path in + let%bind index = map (wrap <@ brackets) @@ decompile_expression e in + let mlu : CST.map_lookup = {path; index} in + ok @@ CST.MapPath (wrap @@ mlu) + | _ -> + let%bind path = decompile_to_path var @@ path in + ok @@ (CST.Path (path) : CST.lhs) + ) + in + let%bind rhs = decompile_expression update in + let assign : CST.assignment = {lhs;assign=rg;rhs} in + let assign = CST.Instr (CST.Assign (wrap @@ assign)) in + let%bind (stat,expr) = decompile_eos output let_result in + let stat = (match stat with + Some (stat) -> Some (List.Ne.cons assign stat) + | None -> Some (assign,[]) + ) + in + return @@ (stat,expr) + | E_let_in {let_binder;rhs;let_result;inline} -> + let%bind lin = decompile_to_data_decl let_binder rhs inline in + let%bind (lst, expr) = decompile_eos Expression let_result in + let lst = match lst with + Some lst -> List.Ne.cons (CST.Data lin) lst + | None -> (CST.Data lin, []) + in + return @@ (Some lst, expr) + | E_raw_code {language; code} -> + let language = wrap @@ wrap @@ language in + let%bind code = decompile_expression code in + let ci : CST.code_inj = {language;code;rbracket=rg} in + return_expr @@ CST.ECodeInj (wrap ci) + | E_constructor {constructor;element} -> + let Constructor constr = constructor in + let constr = wrap constr in + let%bind element = bind decompile_to_tuple_expr @@ get_e_tuple element in + return_expr_with_par @@ CST.EConstr (ConstrApp (wrap (constr, Some element))) + | E_matching {matchee; cases} -> + let%bind expr = decompile_expression matchee in + (match output with + Expression -> + let%bind cases = decompile_matching_expr decompile_expression cases in + let cases : _ CST.case = {kwd_case=rg;expr;kwd_of=rg;enclosing=End rg;lead_vbar=None;cases} in + return_expr @@ CST.ECase (wrap cases) + | Statements -> + let%bind cases = decompile_matching_expr decompile_if_clause cases in + let cases : _ CST.case = {kwd_case=rg;expr;kwd_of=rg;enclosing=End rg;lead_vbar=None;cases} in + return_inst @@ CST.CaseInstr (wrap cases) + ) + | E_record record -> + let record = AST.LMap.to_kv_list record in + let aux (AST.Label str, expr) = + let field_name = wrap str in + let%bind field_expr = decompile_expression expr in + let field : CST.field_assignment = {field_name;assignment=rg;field_expr} in + ok @@ wrap field + in + let%bind record = bind_map_list aux record in + let%bind record = list_to_nsepseq record in + let record = ne_inject (NEInjRecord rg) record in + (* why is the record not empty ? *) + return_expr @@ CST.ERecord (wrap record) + | E_accessor {record; path} -> + (match List.rev path with + Access_map e :: [] -> + let%bind (var,lst) = get_e_accessor @@ record in + let%bind path = decompile_to_path var lst in + let%bind e = decompile_expression e in + let index = wrap @@ brackets @@ e in + let mlu : CST.map_lookup = {path;index} in + return_expr @@ CST.EMap(MapLookUp (wrap @@ mlu)) + | Access_map e :: lst -> + let path = List.rev lst in + let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in + let%bind struct_name = map (decompile_variable) @@ get_e_variable record in + let proj : CST.projection = {struct_name;selector=rg;field_path} in + let path : CST.path = CST.Path (wrap proj) in + let%bind e = decompile_expression e in + let index = wrap @@ brackets @@ e in + let mlu : CST.map_lookup = {path;index} in + return_expr @@ CST.EMap(MapLookUp (wrap @@ mlu)) + | _ -> + let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in + let%bind struct_name = map (decompile_variable) @@ get_e_variable record in + let proj : CST.projection = {struct_name;selector=rg;field_path} in + return_expr @@ CST.EProj (wrap proj) + ) + (* Update on multiple field of the same record. may be removed by adding sugar *) + | E_update {record={expression_content=E_update _;_} as record;path;update} -> + let%bind record = decompile_expression record in + let%bind (record,updates) = match record with + CST.EUpdate {value;_} -> ok @@ (value.record,value.updates) + | _ -> failwith @@ Format.asprintf "Inpossible case %a" AST.PP.expression expr + in + let%bind var,path = match path with + Access_record var::path -> ok @@ (var,path) + | _ -> failwith "Impossible case %a" + in + let%bind field_path = decompile_to_path (Var.of_name var) path in + let%bind field_expr = decompile_expression update in + let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = updates.value.ne_elements in + let updates = wrap @@ ne_inject (NEInjRecord rg) @@ npseq_cons (wrap @@ field_assign) updates in + let update : CST.update = {record;kwd_with=rg;updates} in + return_expr @@ CST.EUpdate (wrap @@ update) + | E_update {record; path; update} -> + let%bind record = map (decompile_variable) @@ get_e_variable record in + let%bind field_expr = decompile_expression update in + let (struct_name,field_path) = List.Ne.of_list path in + (match field_path with + [] -> + (match struct_name with + Access_record name -> + let record : CST.path = Name record in + let field_path = CST.Name (wrap name) in + let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = wrap @@ ne_inject (NEInjRecord rg) @@ (wrap update,[]) in + let update : CST.update = {record;kwd_with=rg;updates;} in + return_expr @@ CST.EUpdate (wrap update) + | Access_tuple _ -> failwith @@ Format.asprintf "invalid tuple update %a" AST.PP.expression expr + | Access_map e -> + let%bind e = decompile_expression e in + let arg : CST.tuple_expr = wrap @@ par @@ nelist_to_npseq (field_expr,[e; CST.EVar record]) in + return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"), arg)) + ) + | _ -> + let%bind struct_name = match struct_name with + Access_record name -> ok @@ wrap name + | Access_tuple _ -> failwith @@ Format.asprintf "invalid tuple update %a" AST.PP.expression expr + | Access_map _ -> failwith @@ Format.asprintf "invalid map update %a" AST.PP.expression expr + in + (match List.rev field_path with + Access_map e :: lst -> + let field_path = List.rev lst in + let%bind field_path = bind_map_list decompile_to_selection field_path in + let%bind field_path = list_to_nsepseq field_path in + let field_path : CST.projection = {struct_name; selector=rg;field_path} in + let field_path = CST.EProj (wrap @@ field_path) in + let%bind e = decompile_expression e in + let arg = wrap @@ par @@ nelist_to_npseq (field_expr, [e; field_path]) in + return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"),arg)) + | _ -> + let%bind field_path = bind_map_list decompile_to_selection field_path in + let%bind field_path = list_to_nsepseq field_path in + let field_path : CST.projection = {struct_name; selector=rg;field_path} in + let field_path : CST.path = CST.Path (wrap @@ field_path) in + let record : CST.path = Name record in + let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in + let updates = wrap @@ ne_inject (NEInjRecord rg) @@ (wrap update,[]) in + let update : CST.update = {record;kwd_with=rg;updates;} in + return_expr @@ CST.EUpdate (wrap update) + ) + ) + | E_ascription {anno_expr;type_annotation} -> + let%bind expr = decompile_expression anno_expr in + let%bind ty = decompile_type_expr type_annotation in + return_expr @@ CST.EAnnot (wrap @@ par (expr,rg,ty)) + | E_cond {condition;then_clause;else_clause} -> + let%bind test = decompile_expression condition in + (match output with + Expression -> + let%bind ifso = decompile_expression then_clause in + let%bind ifnot = decompile_expression else_clause in + let cond : CST.cond_expr = {kwd_if=rg;test;kwd_then=rg;ifso;terminator=Some rg;kwd_else=rg;ifnot} in + return_expr @@ CST.ECond (wrap cond) + | Statements -> + let%bind ifso = decompile_if_clause then_clause in + let%bind ifnot = decompile_if_clause else_clause in + let cond : CST.conditional = {kwd_if=rg;test;kwd_then=rg;ifso;terminator=Some rg; kwd_else=rg;ifnot} in + return_inst @@ CST.Cond (wrap cond) + ) + | E_sequence {expr1;expr2} -> + let%bind expr1 = decompile_statements expr1 in + let%bind (expr2,next) = decompile_eos Statements expr2 in + let expr1 = Option.unopt ~default:expr1 @@ Option.map (List.Ne.append expr1) expr2 in + return @@ (Some expr1, next) + | E_skip -> return_inst @@ CST.Skip rg + | E_tuple tuple -> + let%bind tuple = bind_map_list decompile_expression tuple in + let%bind tuple = list_to_nsepseq tuple in + return_expr @@ CST.ETuple (wrap @@ par tuple) + | E_map map -> + let%bind map = bind_map_list (bind_map_pair decompile_expression) map in + let aux (k,v) = + let binding : CST.binding = {source=k;arrow=rg;image=v} in + wrap @@ binding + in + let map = list_to_sepseq @@ List.map aux map in + return_expr @@ CST.EMap (MapInj (wrap @@ inject (InjMap rg) @@ map)) + | E_big_map big_map -> + let%bind big_map = bind_map_list (bind_map_pair decompile_expression) big_map in + let aux (k,v) = + let binding : CST.binding = {source=k;arrow=rg;image=v} in + wrap @@ binding + in + let big_map = list_to_sepseq @@ List.map aux big_map in + return_expr @@ CST.EMap (BigMapInj (wrap @@ inject (InjBigMap rg) @@ big_map)) + | E_list lst -> + let%bind lst = bind_map_list decompile_expression lst in + let lst = list_to_sepseq lst in + return_expr @@ CST.EList (EListComp (wrap @@ inject (InjList rg) @@ lst)) + | E_set set -> + let%bind set = bind_map_list decompile_expression set in + let set = list_to_sepseq set in + return_expr @@ CST.ESet (SetInj (wrap @@ inject (InjSet rg) @@ set)) + | E_assign {variable;access_path;expression} -> + let%bind lhs = decompile_to_lhs variable access_path in + let%bind rhs = decompile_expression expression in + let assign : CST.assignment = {lhs;assign=rg;rhs} in + return_inst @@ Assign (wrap assign) + | E_for {binder;start;final;increment;body} -> + let binder = decompile_variable binder in + let%bind init = decompile_expression start in + let%bind bound = decompile_expression final in + let%bind step = decompile_expression increment in + let step = Some (rg, step) in + let%bind (block,_next) = decompile_to_block body in + let block = wrap @@ Option.unopt ~default:(empty_block) block in + let fl : CST.for_int = {kwd_for=rg;binder;assign=rg;init;kwd_to=rg;bound;step;block} in + return_inst @@ CST.Loop (For (ForInt (wrap fl))) + | E_for_each {binder;collection;collection_type;body} -> + let var = decompile_variable @@ fst binder in + let bind_to = Option.map (fun x -> (rg,decompile_variable x)) @@ snd binder in + let%bind expr = decompile_expression collection in + let collection = match collection_type with + Map -> CST.Map rg | Set -> Set rg | List -> List rg in + let%bind (block,_next) = decompile_to_block body in + let block = wrap @@ Option.unopt ~default:(empty_block) block in + let fc : CST.for_collect = {kwd_for=rg;var;bind_to;kwd_in=rg;collection;expr;block} in + return_inst @@ CST.Loop (For (ForCollect (wrap fc))) + | E_while {condition;body} -> + let%bind cond = decompile_expression condition in + let%bind (block,_next) = decompile_to_block body in + let block = wrap @@ Option.unopt ~default:(empty_block) block in + let loop : CST.while_loop = {kwd_while=rg;cond;block} in + return_inst @@ CST.Loop (While (wrap loop)) + +and decompile_if_clause : AST.expression -> (CST.if_clause, _) result = fun e -> + let%bind clause = decompile_statements e in + match clause with + CST.Instr instr,[] -> + ok @@ CST.ClauseInstr instr + | _ -> + let clause = nelist_to_npseq clause, Some rg in + ok @@ CST.ClauseBlock (ShortBlock (wrap @@ braces @@ clause)) + +and decompile_to_data_decl : (AST.expression_variable * AST.type_expression option) -> AST.expression -> bool -> (CST.data_decl, _) result = fun (name,ty_opt) expr inline -> + let name = decompile_variable name in + let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in + let attributes : CST.attr_decl option = match inline with + true -> Some (wrap @@ ne_inject (NEInjAttr rg) @@ (wrap @@ "inline",[])) + | false -> None + in + let fun_name = name in + match expr.expression_content with + E_lambda lambda -> + let%bind (param,ret_type,return) = decompile_lambda lambda in + let fun_decl : CST.fun_decl = {kwd_recursive=None;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in + ok @@ CST.LocalFun (wrap fun_decl) + | E_recursive {lambda; _} -> + let%bind (param,ret_type,return) = decompile_lambda lambda in + let fun_decl : CST.fun_decl = {kwd_recursive=Some rg;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in + ok @@ CST.LocalFun (wrap fun_decl) + | _ -> + let%bind init = decompile_expression expr in + let const_decl : CST.const_decl = {kwd_const=rg;name;const_type;equal=rg;init;terminator=Some rg; attributes} in + let data_decl : CST.data_decl = LocalConst (wrap const_decl) in + ok @@ data_decl + +and decompile_to_lhs : AST.expression_variable -> AST.access list -> (CST.lhs, _) result = fun var access -> + match List.rev access with + [] -> ok @@ (CST.Path (Name (decompile_variable var)) : CST.lhs) + | hd :: tl -> + match hd with + | AST.Access_map e -> + let%bind path = decompile_to_path var @@ List.rev tl in + let%bind index = map (wrap <@ brackets) @@ decompile_expression e in + let mlu: CST.map_lookup = {path;index} in + ok @@ CST.MapPath (wrap @@ mlu) + | _ -> + let%bind path = decompile_to_path var @@ access in + ok @@ (CST.Path (path) : CST.lhs) + +and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access -> + let struct_name = decompile_variable var in + match access with + [] -> ok @@ CST.Name struct_name + | lst -> + let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection lst in + let path : CST.projection = {struct_name;selector=rg;field_path} in + ok @@ (CST.Path (wrap @@ path) : CST.path) + +and decompile_to_selection : AST.access -> (CST.selection, _) result = fun access -> + match access with + Access_tuple index -> ok @@ CST.Component (wrap @@ ("",index)) + | Access_record str -> ok @@ CST.FieldName (wrap str) + | Access_map _ -> + failwith @@ Format.asprintf + "Can't decompile access_map to selection" + +and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} -> + let var = decompile_variable binder in + let%bind param_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) input_type in + let param_const : CST.param_const = {kwd_const=rg;var;param_type} in + let param_decl : CST.param_decl = ParamConst (wrap param_const) in + let param = nelist_to_npseq (param_decl, []) in + let param : CST.parameters = wrap @@ par param in + let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in + let%bind return = decompile_expression result in + ok @@ (param,ret_type,return) + +and decompile_matching_expr : type a.(AST.expr ->(a,_) result) -> AST.matching_expr -> ((a CST.case_clause Region.reg, Region.t) Parser_shared.Utils.nsepseq Region.reg,_) result = +fun f m -> + let%bind cases = match m with + Match_variable (var, _ty_opt, expr) -> + let pattern : CST.pattern = PVar (decompile_variable var) in + let%bind rhs = f expr in + let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in + ok @@ [wrap case] + | Match_tuple (lst, _ty_opt, expr) -> + let aux var = CST.PVar (decompile_variable var) in + let%bind tuple = list_to_nsepseq @@ List.map aux lst in + let pattern : CST.pattern = PTuple (wrap @@ par @@ tuple) in + let%bind rhs = f expr in + let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in + ok @@ [wrap case] + | Match_record _ -> failwith "match_record not availiable yet" + | Match_option {match_none;match_some}-> + let%bind rhs = f match_none in + let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in + let%bind rhs = f @@ snd match_some in + let var = wrap @@ par @@ CST.PVar (decompile_variable @@ fst match_some)in + let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in + ok @@ [wrap some_case;wrap none_case] + | Match_list {match_nil; match_cons} -> + let (hd,tl,expr) = match_cons in + let hd = CST.PVar (decompile_variable hd) in + let tl = CST.PVar (decompile_variable tl) in + let cons = (hd,[rg,tl]) in + let%bind rhs = f @@ expr in + let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in + let%bind rhs = f @@ match_nil in + let nil_case : _ CST.case_clause = {pattern=PList (PNil rg);arrow=rg; rhs} in + ok @@ [wrap cons_case; wrap nil_case] + | Match_variant lst -> + let aux ((c,v),e) = + let AST.Constructor c = c in + let constr = wrap @@ c in + let var : CST.pattern = PVar (decompile_variable v) in + let tuple = wrap @@ par @@ (var,[]) in + let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in + let%bind rhs = f e in + let case : _ CST.case_clause = {pattern;arrow=rg;rhs} in + ok @@ wrap case + in + bind_map_list aux lst + in + map wrap @@ list_to_nsepseq cases +let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _) result = fun decl -> + let decl = Location.unwrap decl in + let wrap value = ({value;region=Region.ghost} : _ Region.reg) in + match decl with + Declaration_type (name, te) -> + let kwd_type = Region.ghost + and name = decompile_variable name + and kwd_is = Region.ghost in + let%bind type_expr = decompile_type_expr te in + let terminator = Some Region.ghost in + ok @@ CST.TypeDecl (wrap (CST.{kwd_type; name; kwd_is; type_expr; terminator})) + | Declaration_constant (var, ty_opt, inline, expr) -> + let attributes = match inline with + true -> + let attr = wrap "inline" in + let ne_inj : _ CST.ne_injection = + {kind=NEInjAttr rg;enclosing=End rg;ne_elements=(attr, []);terminator=Some rg} in + let attr_decl = wrap ne_inj in + Some attr_decl + | false -> None + in + let name = decompile_variable var in + let fun_name = name in + match expr.expression_content with + E_lambda lambda -> + let%bind (param,ret_type,return) = decompile_lambda lambda in + let fun_decl : CST.fun_decl = {kwd_recursive=None;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in + ok @@ CST.FunDecl (wrap fun_decl) + | E_recursive {lambda; _} -> + let%bind (param,ret_type,return) = decompile_lambda lambda in + let fun_decl : CST.fun_decl = {kwd_recursive=Some rg;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in + ok @@ CST.FunDecl (wrap fun_decl) + | _ -> + let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in + let%bind init = decompile_expression expr in + let const_decl : CST.const_decl = {kwd_const=rg;name;const_type;equal=rg;init;terminator=Some rg; attributes} in + ok @@ CST.ConstDecl (wrap const_decl) + +let decompile_program : AST.program -> (CST.ast, _) result = fun prg -> + let%bind decl = bind_map_list decompile_declaration prg in + let decl = List.Ne.of_list decl in + ok @@ ({decl;eof=rg}: CST.ast) diff --git a/src/passes/03-tree_abstraction/pascaligo/pascaligo.ml b/src/passes/03-tree_abstraction/pascaligo/pascaligo.ml index 6c7382ac1..08a9a6946 100644 --- a/src/passes/03-tree_abstraction/pascaligo/pascaligo.ml +++ b/src/passes/03-tree_abstraction/pascaligo/pascaligo.ml @@ -1,8 +1,12 @@ module CST = Cst.Pascaligo module AST = Ast_imperative -module Compiler = Compiler +module Compiler = Compiler +module Decompiler = Decompiler module Errors = Errors -let compile_program = Compiler.compile_program -let compile_expression = Compiler.compile_expression +let compile_program = Compiler.compile_program +let compile_expression = Compiler.compile_expression + +let decompile_program = Decompiler.decompile_program +let decompile_expression = Decompiler.decompile_expression diff --git a/src/passes/03-tree_abstraction/pascaligo/pascaligo.mli b/src/passes/03-tree_abstraction/pascaligo/pascaligo.mli index 3a296dcb0..cca5cd45a 100644 --- a/src/passes/03-tree_abstraction/pascaligo/pascaligo.mli +++ b/src/passes/03-tree_abstraction/pascaligo/pascaligo.mli @@ -6,10 +6,14 @@ module Errors = Errors open Trace -(** Convert a concrete PascaLIGO expression AST to the imperative +(** Convert a concrete PascaLIGO expression CST to the imperative expression AST used by the compiler. *) -val compile_expression : CST.expr -> (AST.expr , Errors.abs_error) result +val compile_expression : CST.expr -> (AST.expr, Errors.abs_error) result -(** Convert a concrete PascaLIGO program AST to the miperative program +(** Convert a concrete PascaLIGO program CST to the miperative program AST used by the compiler. *) val compile_program : CST.ast -> (AST.program, Errors.abs_error) result + +val decompile_expression : AST.expr -> (CST.expr, _) result + +val decompile_program : AST.program -> (CST.ast, _) result diff --git a/src/passes/05-purification/compiler.ml b/src/passes/05-purification/compiler.ml index b0f87ef1e..03754c0d5 100644 --- a/src/passes/05-purification/compiler.ml +++ b/src/passes/05-purification/compiler.ml @@ -252,7 +252,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression, let%bind condition = compile_expression condition in let%bind then_clause' = compile_expression then_clause in let%bind else_clause' = compile_expression else_clause in - let env = Var.fresh () in + let env = Var.fresh ~name:"env" () in let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in let then_clause = add_to_end then_clause (O.e_variable env) in @@ -283,7 +283,9 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression, | I.E_assign {variable; access_path; expression} -> let%bind access_path = compile_path access_path in let%bind expression = compile_expression expression in - let rhs = O.e_update ~loc (O.e_variable ~loc variable) access_path expression in + let rhs = match access_path with + [] -> expression + | _ -> O.e_update ~loc (O.e_variable ~loc variable) access_path expression in ok @@ fun expr -> (match expr with | None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ()) | Some e -> O.e_let_in ~loc (variable, None) true false rhs e @@ -328,7 +330,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp let%bind match_none' = compile_expression match_none in let (n,expr) = match_some in let%bind expr' = compile_expression expr in - let env = Var.fresh () in + let env = Var.fresh ~name:"env" () in let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in let match_none = add_to_end match_none (O.e_variable env) in @@ -348,7 +350,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp let%bind match_nil' = compile_expression match_nil in let (hd,tl,expr) = match_cons in let%bind expr' = compile_expression expr in - let env = Var.fresh () in + let env = Var.fresh ~name:"name" () in let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in let match_nil = add_to_end match_nil (O.e_variable env) in @@ -365,7 +367,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp else return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')} | I.Match_variant lst -> - let env = Var.fresh () in + let env = Var.fresh ~name:"env" () in let aux fv ((c,n),expr) = let%bind expr = compile_expression expr in let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in @@ -401,8 +403,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr) and compile_while I.{condition;body} = - let env_rec = Var.fresh () in - let binder = Var.fresh () in + let env_rec = Var.fresh ~name:"env_rec" () in + let binder = Var.fresh ~name:"binder" () in let%bind cond = compile_expression condition in let ctrl = @@ -436,7 +438,7 @@ and compile_while I.{condition;body} = and compile_for I.{binder;start;final;increment;body} = - let env_rec = Var.fresh () in + let env_rec = Var.fresh ~name:"env_rec" () in (*Make the cond and the step *) let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) (I.t_bool ()) in let%bind cond = compile_expression cond in @@ -481,8 +483,8 @@ and compile_for I.{binder;start;final;increment;body} = ok @@ restore_mutable_variable return_expr captured_name_list env_rec and compile_for_each I.{binder;collection;collection_type; body} = - let env_rec = Var.fresh () in - let args = Var.fresh () in + let env_rec = Var.fresh ~name:"env_rec" () in + let args = Var.fresh ~name:"args" () in let%bind element_names = ok @@ match snd binder with | Some v -> [fst binder;v] diff --git a/src/passes/07-desugaring/compiler.ml b/src/passes/07-desugaring/compiler.ml index 58fbd38de..e9201713e 100644 --- a/src/passes/07-desugaring/compiler.ml +++ b/src/passes/07-desugaring/compiler.ml @@ -6,7 +6,7 @@ open Errors let rec compile_type_expression : I.type_expression -> (O.type_expression , desugaring_error) result = fun te -> - let return tc = ok @@ O.make_t ~loc:te.location tc in + let return tc = ok @@ O.make_t ~loc:te.location ~sugar:te tc in match te.type_content with | I.T_sum sum -> let sum = I.CMap.to_kv_list sum in @@ -48,9 +48,9 @@ let rec compile_type_expression : I.type_expression -> (O.type_expression , desu return @@ T_operator (type_operator, lst) let rec compile_expression : I.expression -> (O.expression , desugaring_error) result = - fun e -> - let return expr = ok @@ O.make_e ~loc:e.location expr in - match e.expression_content with + fun sugar -> + let return expr = ok @@ O.make_e ~loc:sugar.location ~sugar expr in + match sugar.expression_content with | I.E_literal literal -> return @@ O.E_literal literal | I.E_constant {cons_name;arguments} -> let%bind arguments = bind_map_list compile_expression arguments in @@ -81,7 +81,7 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r return @@ O.E_constructor {constructor;element} | I.E_matching {matchee; cases} -> let%bind matchee = compile_expression matchee in - compile_matching e.location matchee cases + compile_matching sugar matchee cases | I.E_record record -> let record = I.LMap.to_kv_list record in let%bind record = @@ -93,33 +93,33 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r return @@ O.E_record (O.LMap.of_list record) | I.E_accessor {record;path} -> let%bind record = compile_expression record in - let accessor ?loc e a = + let accessor ?loc expr a = match a with - I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i)) - | I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a) + I.Access_tuple i -> ok @@ O.e_record_accessor ?loc expr (Label (Z.to_string i)) + | I.Access_record a -> ok @@ O.e_record_accessor ?loc expr (Label a) | I.Access_map k -> let%bind k = compile_expression k in - ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e] + ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;expr] in bind_fold_list accessor record path | I.E_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in - let accessor ?loc e a = + let accessor ?loc expr a = match a with - I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i)) - | I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a) + I.Access_tuple i -> ok @@ O.e_record_accessor ?loc expr (Label (Z.to_string i)) + | I.Access_record a -> ok @@ O.e_record_accessor ?loc expr (Label a) | I.Access_map k -> let%bind k = compile_expression k in - ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e] + ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;expr] in - let updator ?loc (s:O.expression) a e = + let updator ?loc (s:O.expression) a expr = match a with - I.Access_tuple i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) e - | I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e + I.Access_tuple i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) expr + | I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) expr | I.Access_map k -> let%bind k = compile_expression k in - ok @@ O.e_constant ?loc C_MAP_ADD [k;e;s] + ok @@ O.e_constant ?loc C_MAP_ADD [k;expr;s] in let aux (s, e : O.expression * _) lst = let%bind s' = accessor ~loc:s.location s lst in @@ -176,7 +176,7 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in return @@ O.E_let_in {let_binder=(Var.of_name "_", Some (O.t_unit ())); rhs=expr1;let_result=expr2; inline=false} - | I.E_skip -> ok @@ O.e_unit ~loc:e.location () + | I.E_skip -> ok @@ O.e_unit ~loc:sugar.location ~sugar () | I.E_tuple t -> let aux (i,acc) el = let%bind el = compile_expression el in @@ -191,19 +191,20 @@ and compile_lambda : I.lambda -> (O.lambda , desugaring_error) result = let%bind output_type = bind_map_option compile_type_expression output_type in let%bind result = compile_expression result in ok @@ O.{binder;input_type;output_type;result} -and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expression, desugaring_error) result = - fun loc e m -> +and compile_matching : I.expression -> O.expression -> I.matching_expr -> (O.expression, desugaring_error) result = + fun sugar e m -> + let loc = sugar.location in match m with | I.Match_list {match_nil;match_cons} -> let%bind match_nil = compile_expression match_nil in let (hd,tl,expr) = match_cons in let%bind expr = compile_expression expr in - ok @@ O.e_matching ~loc e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)} + ok @@ O.e_matching ~loc ~sugar e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)} | I.Match_option {match_none;match_some} -> let%bind match_none = compile_expression match_none in let (n,expr) = match_some in let%bind expr = compile_expression expr in - ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)} + ok @@ O.e_matching ~loc ~sugar e @@ O.Match_option {match_none; match_some=(n,expr)} | I.Match_variant lst -> let%bind lst = bind_map_list ( fun ((c,n),expr) -> @@ -211,7 +212,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre ok @@ ((c,n),expr) ) lst in - ok @@ O.e_matching ~loc e @@ O.Match_variant lst + ok @@ O.e_matching ~loc ~sugar e @@ O.Match_variant lst | I.Match_record (fields,field_types, expr) -> let combine fields field_types = match field_types with @@ -221,7 +222,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre let%bind next = compile_expression expr in let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in let aux ((index,expr) : int * _ ) ((field,name): (O.label * (O.expression_variable * O.type_expression option))) = - let f = fun expr' -> O.e_let_in name false (O.e_record_accessor e field) expr' in + let f = fun expr' -> O.e_let_in ~sugar name false (O.e_record_accessor ~sugar e field) expr' in (index+1, fun expr' -> expr (f expr')) in let (_,header) = List.fold_left aux (0, fun e -> e) @@ @@ -238,7 +239,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre let%bind next = compile_expression expr in let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in let aux ((index,expr) : int * _ ) (field: O.expression_variable * O.type_expression option) = - let f = fun expr' -> O.e_let_in field false (O.e_record_accessor e (Label (string_of_int index))) expr' in + let f = fun expr' -> O.e_let_in ~sugar field false (O.e_record_accessor ~sugar e (Label (string_of_int index))) expr' in (index+1, fun expr' -> expr (f expr')) in let (_,header) = List.fold_left aux (0, fun e -> e) @@ @@ -248,7 +249,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre | I.Match_variable (a, ty_opt, expr) -> let%bind ty_opt = bind_map_option compile_type_expression ty_opt in let%bind expr = compile_expression expr in - ok @@ O.e_let_in (a,ty_opt) false e expr + ok @@ O.e_let_in ~sugar (a,ty_opt) false e expr let compile_declaration : I.declaration Location.wrap -> _ = fun {wrap_content=declaration;location} -> @@ -257,7 +258,7 @@ let compile_declaration : I.declaration Location.wrap -> _ = | I.Declaration_constant (n, te_opt, inline, expr) -> let%bind expr = compile_expression expr in let%bind te_opt = bind_map_option compile_type_expression te_opt in - return @@ O.Declaration_constant (n, te_opt, inline, expr) + return @@ O.Declaration_constant (n, te_opt, {inline}, expr) | I.Declaration_type (n, te) -> let%bind te = compile_type_expression te in return @@ O.Declaration_type (n,te) diff --git a/src/passes/07-desugaring/decompiler.ml b/src/passes/07-desugaring/decompiler.ml index 7dfcdb514..200bedeae 100644 --- a/src/passes/07-desugaring/decompiler.ml +++ b/src/passes/07-desugaring/decompiler.ml @@ -7,101 +7,107 @@ open Errors let rec decompile_type_expression : O.type_expression -> (I.type_expression, desugaring_error) result = fun te -> let return te = ok @@ I.make_t te in - match te.type_content with - | O.T_sum sum -> - let sum = I.CMap.to_kv_list sum in - let%bind sum = - bind_map_list (fun (k,v) -> - let {ctor_type;michelson_annotation;ctor_decl_pos} : O.ctor_content = v in - let%bind ctor_type = decompile_type_expression ctor_type in - let v' : I.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in - ok @@ (k,v') - ) sum - in - return @@ I.T_sum (O.CMap.of_list sum) - | O.T_record record -> - let record = I.LMap.to_kv_list record in - let%bind record = - bind_map_list (fun (k,v) -> - let {field_type;field_annotation;field_decl_pos} : O.field_content = v in - let%bind field_type = decompile_type_expression field_type in - let v' : I.field_content = {field_type ; michelson_annotation=field_annotation ; field_decl_pos} in - ok @@ (k,v') - ) record - in - return @@ I.T_record (O.LMap.of_list record) - | O.T_arrow {type1;type2} -> - let%bind type1 = decompile_type_expression type1 in - let%bind type2 = decompile_type_expression type2 in - return @@ T_arrow {type1;type2} - | O.T_variable type_variable -> return @@ T_variable type_variable - | O.T_constant type_constant -> return @@ T_constant type_constant - | O.T_operator (type_operator, lst) -> - let%bind lst = bind_map_list decompile_type_expression lst in - return @@ T_operator (type_operator, lst) + match te.sugar with + Some te -> ok @@ te + | None -> + match te.content with + | O.T_sum sum -> + let sum = I.CMap.to_kv_list sum in + let%bind sum = + bind_map_list (fun (k,v) -> + let {ctor_type;michelson_annotation;ctor_decl_pos} : O.ctor_content = v in + let%bind ctor_type = decompile_type_expression ctor_type in + let v' : I.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in + ok @@ (k,v') + ) sum + in + return @@ I.T_sum (O.CMap.of_list sum) + | O.T_record record -> + let record = I.LMap.to_kv_list record in + let%bind record = + bind_map_list (fun (k,v) -> + let {field_type;field_annotation;field_decl_pos} : O.field_content = v in + let%bind field_type = decompile_type_expression field_type in + let v' : I.field_content = {field_type ; michelson_annotation=field_annotation ; field_decl_pos} in + ok @@ (k,v') + ) record + in + return @@ I.T_record (O.LMap.of_list record) + | O.T_arrow {type1;type2} -> + let%bind type1 = decompile_type_expression type1 in + let%bind type2 = decompile_type_expression type2 in + return @@ T_arrow {type1;type2} + | O.T_variable type_variable -> return @@ T_variable type_variable + | O.T_constant type_constant -> return @@ T_constant type_constant + | O.T_operator (type_operator, lst) -> + let%bind lst = bind_map_list decompile_type_expression lst in + return @@ T_operator (type_operator, lst) let rec decompile_expression : O.expression -> (I.expression, desugaring_error) result = fun e -> let return expr = ok @@ I.make_e ~loc:e.location expr in - match e.expression_content with - O.E_literal lit -> return @@ I.E_literal lit - | O.E_constant {cons_name;arguments} -> - let%bind arguments = bind_map_list decompile_expression arguments in - return @@ I.E_constant {cons_name;arguments} - | O.E_variable name -> return @@ I.E_variable name - | O.E_application {lamb; args} -> - let%bind lamb = decompile_expression lamb in - let%bind args = decompile_expression args in - return @@ I.E_application {lamb; args} - | O.E_lambda lambda -> - let%bind lambda = decompile_lambda lambda in - return @@ I.E_lambda lambda - | O.E_recursive {fun_name;fun_type;lambda} -> - let%bind fun_type = decompile_type_expression fun_type in - let%bind lambda = decompile_lambda lambda in - return @@ I.E_recursive {fun_name;fun_type;lambda} - | O.E_let_in {let_binder;inline=false;rhs=expr1;let_result=expr2} when let_binder = (Var.of_name "_", Some (O.t_unit ())) -> - let%bind expr1 = decompile_expression expr1 in - let%bind expr2 = decompile_expression expr2 in - return @@ I.E_sequence {expr1;expr2} - | O.E_let_in {let_binder;inline;rhs;let_result} -> - let (binder,ty_opt) = let_binder in - let%bind ty_opt = bind_map_option decompile_type_expression ty_opt in - let%bind rhs = decompile_expression rhs in - let%bind let_result = decompile_expression let_result in - return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} - | O.E_raw_code {language;code} -> - let%bind code = decompile_expression code in - return @@ I.E_raw_code {language;code} - | O.E_constructor {constructor;element} -> - let%bind element = decompile_expression element in - return @@ I.E_constructor {constructor;element} - | O.E_matching {matchee; cases} -> - let%bind matchee = decompile_expression matchee in - let%bind cases = decompile_matching cases in - return @@ I.E_matching {matchee;cases} - | O.E_record record -> - let record = I.LMap.to_kv_list record in - let%bind record = - bind_map_list (fun (k,v) -> - let%bind v = decompile_expression v in - ok @@ (k,v) - ) record - in - return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {record;path} -> - let%bind record = decompile_expression record in - let Label path = path in - return @@ I.E_accessor {record;path=[I.Access_record path]} - | O.E_record_update {record;path;update} -> - let%bind record = decompile_expression record in - let%bind update = decompile_expression update in - let Label path = path in - return @@ I.E_update {record;path=[I.Access_record path];update} - | O.E_ascription {anno_expr; type_annotation} -> - let%bind anno_expr = decompile_expression anno_expr in - let%bind type_annotation = decompile_type_expression type_annotation in - return @@ I.E_ascription {anno_expr; type_annotation} + match e.sugar with + Some e -> ok @@ e + | None -> + match e.content with + O.E_literal lit -> return @@ I.E_literal lit + | O.E_constant {cons_name;arguments} -> + let%bind arguments = bind_map_list decompile_expression arguments in + return @@ I.E_constant {cons_name;arguments} + | O.E_variable name -> return @@ I.E_variable name + | O.E_application {lamb; args} -> + let%bind lamb = decompile_expression lamb in + let%bind args = decompile_expression args in + return @@ I.E_application {lamb; args} + | O.E_lambda lambda -> + let%bind lambda = decompile_lambda lambda in + return @@ I.E_lambda lambda + | O.E_recursive {fun_name;fun_type;lambda} -> + let%bind fun_type = decompile_type_expression fun_type in + let%bind lambda = decompile_lambda lambda in + return @@ I.E_recursive {fun_name;fun_type;lambda} + | O.E_let_in {let_binder;inline=false;rhs=expr1;let_result=expr2} when let_binder = (Var.of_name "_", Some (O.t_unit ())) -> + let%bind expr1 = decompile_expression expr1 in + let%bind expr2 = decompile_expression expr2 in + return @@ I.E_sequence {expr1;expr2} + | O.E_let_in {let_binder;inline;rhs;let_result} -> + let (binder,ty_opt) = let_binder in + let%bind ty_opt = bind_map_option decompile_type_expression ty_opt in + let%bind rhs = decompile_expression rhs in + let%bind let_result = decompile_expression let_result in + return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} + | O.E_raw_code {language;code} -> + let%bind code = decompile_expression code in + return @@ I.E_raw_code {language;code} + | O.E_constructor {constructor;element} -> + let%bind element = decompile_expression element in + return @@ I.E_constructor {constructor;element} + | O.E_matching {matchee; cases} -> + let%bind matchee = decompile_expression matchee in + let%bind cases = decompile_matching cases in + return @@ I.E_matching {matchee;cases} + | O.E_record record -> + let record = I.LMap.to_kv_list record in + let%bind record = + bind_map_list (fun (k,v) -> + let%bind v = decompile_expression v in + ok @@ (k,v) + ) record + in + return @@ I.E_record (O.LMap.of_list record) + | O.E_record_accessor {record;path} -> + let%bind record = decompile_expression record in + let Label path = path in + return @@ I.E_accessor {record;path=[I.Access_record path]} + | O.E_record_update {record;path;update} -> + let%bind record = decompile_expression record in + let%bind update = decompile_expression update in + let Label path = path in + return @@ I.E_update {record;path=[I.Access_record path];update} + | O.E_ascription {anno_expr; type_annotation} -> + let%bind anno_expr = decompile_expression anno_expr in + let%bind type_annotation = decompile_type_expression type_annotation in + return @@ I.E_ascription {anno_expr; type_annotation} and decompile_lambda : O.lambda -> (I.lambda, desugaring_error) result = fun {binder;input_type;output_type;result}-> @@ -134,7 +140,7 @@ and decompile_matching : O.matching_expr -> (I.matching_expr, desugaring_error) let decompile_declaration : O.declaration Location.wrap -> _ result = fun {wrap_content=declaration;location} -> let return decl = ok @@ Location.wrap ~loc:location decl in match declaration with - | O.Declaration_constant (n, te_opt, inline, expr) -> + | O.Declaration_constant (n, te_opt, {inline}, expr) -> let%bind expr = decompile_expression expr in let%bind te_opt = bind_map_option decompile_type_expression te_opt in return @@ I.Declaration_constant (n, te_opt, inline, expr) diff --git a/src/passes/08-self_ast_core/helpers.ml b/src/passes/08-self_ast_core/helpers.ml index ad15266be..469094bd3 100644 --- a/src/passes/08-self_ast_core/helpers.ml +++ b/src/passes/08-self_ast_core/helpers.ml @@ -3,7 +3,6 @@ open Trace open Stage_common.Helpers include Stage_common.PP -include Stage_common.Types.Ast_generic_type(Ast_core_parameter) let bind_map_cmap f map = bind_cmap ( CMap.map @@ -23,7 +22,7 @@ type ('a,'err) folder = 'a -> expression -> ('a, 'err) result let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a,'err) result = fun f init e -> let self = fold_expression f in let%bind init' = f init e in - match e.expression_content with + match e.content with | E_literal _ | E_variable _ | E_raw_code _ -> ok init' | E_constant {arguments=lst} -> ( let%bind res = bind_fold_list self init' lst in @@ -98,8 +97,8 @@ type 'err abs_mapper = let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) result = fun f e -> let self = map_expression f in let%bind e' = f e in - let return expression_content = ok { e' with expression_content } in - match e'.expression_content with + let return content = ok { e' with content } in + match e'.content with | E_ascription ascr -> ( let%bind e' = self ascr.anno_expr in return @@ E_ascription {ascr with anno_expr=e'} @@ -151,11 +150,11 @@ let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) re | E_literal _ | E_variable _ | E_raw_code _ as e' -> return e' and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression , 'err) result = - fun f ({type_content ; location ; type_meta} as te) -> + fun f ({content ; sugar; location } as te) -> let self = map_type_expression f in let%bind te' = f te in - let return type_content = ok { type_content; location ; type_meta } in - match type_content with + let return content = ok @@ ({ content; sugar; location}: type_expression) in + match content with | T_sum temap -> let%bind temap' = bind_map_cmap self temap in return @@ (T_sum temap') @@ -212,8 +211,8 @@ let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a let%bind (continue, init',e') = f a e in if (not continue) then ok(init',e') else - let return expression_content = { e' with expression_content } in - match e'.expression_content with + let return content = { e' with content } in + match e'.content with | E_ascription ascr -> ( let%bind (res,e') = self init' ascr.anno_expr in ok (res, return @@ E_ascription {ascr with anno_expr=e'}) diff --git a/src/passes/09-typing/08-typer-new/typer.ml b/src/passes/09-typing/08-typer-new/typer.ml index 2406858a8..8a3ba7db5 100644 --- a/src/passes/09-typing/08-typer-new/typer.ml +++ b/src/passes/09-typing/08-typer-new/typer.ml @@ -24,7 +24,7 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st let%bind tv = evaluate_type env type_expression in let env' = Environment.add_type (type_name) tv env in ok (env', state , None) - | Declaration_constant (binder , tv_opt , inline, expression) -> ( + | Declaration_constant (binder , tv_opt , attr, expression) -> ( (* Determine the type of the expression and add it to the environment *) @@ -33,7 +33,7 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st trace (constant_declaration_tracer binder expression tv'_opt) @@ type_expression env state expression in let post_env = Environment.add_ez_declaration binder expr env in - ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} )) + ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline=attr.inline} )) ) and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result = @@ -111,7 +111,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin *) and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result = let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in - match t.type_content with + match t.content with | T_arrow {type1;type2} -> let%bind type1 = evaluate_type e type1 in let%bind type2 = evaluate_type e type2 in @@ -210,7 +210,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression ok @@ (expr' , new_state) in let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in trace (expression_tracer ae) @@ - match ae.expression_content with + match ae.content with (* TODO: this file should take care only of the order in which program fragments are translated by Wrap.xyz diff --git a/src/passes/09-typing/08-typer-new/wrap.ml b/src/passes/09-typing/08-typer-new/wrap.ml index 0b88ed0c6..45c0481b3 100644 --- a/src/passes/09-typing/08-typer-new/wrap.ml +++ b/src/passes/09-typing/08-typer-new/wrap.ml @@ -62,7 +62,7 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun p_constant csttag (List.map type_expression_to_type_value args) let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te -> - match te.type_content with + match te.content with | T_sum kvmap -> let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in let tlist = List.map (fun ({ctor_type;_}:I.ctor_content) -> ctor_type) (I.CMap.to_list kvmap) in diff --git a/src/passes/09-typing/08-typer-old/typer.ml b/src/passes/09-typing/08-typer-old/typer.ml index e1d755c7c..93292e5af 100644 --- a/src/passes/09-typing/08-typer-old/typer.ml +++ b/src/passes/09-typing/08-typer-old/typer.ml @@ -290,13 +290,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state) let%bind tv = evaluate_type env type_expr in let env' = Environment.add_type (type_binder) tv env in ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } )) - | Declaration_constant (binder , tv_opt , inline, expression) -> ( + | Declaration_constant (binder , tv_opt , attr, expression) -> ( let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind expr = trace (constant_declaration_error_tracer binder expression tv'_opt) @@ type_expression' ?tv_opt:tv'_opt env expression in let post_env = Environment.add_ez_declaration binder expr env in - ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline})) + ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline=attr.inline})) ) and type_match : (environment -> I.expression -> (O.expression , typer_error) result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr, typer_error) result = @@ -349,7 +349,7 @@ and type_match : (environment -> I.expression -> (O.expression , typer_error) re and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result = let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in - match t.type_content with + match t.content with | T_arrow {type1;type2} -> let%bind type1 = evaluate_type e type1 in let%bind type2 = evaluate_type e type2 in @@ -456,7 +456,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let location = ae.location in ok @@ make_e ~location expr tv in trace (expression_tracer ae) @@ - match ae.expression_content with + match ae.content with (* Basic *) | E_variable name -> let%bind tv' = @@ -561,7 +561,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression return (E_lambda lambda ) lambda_type | E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ; arguments=[ - ( { expression_content = (I.E_lambda { binder = lname ; + ( { content = (I.E_lambda { binder = lname ; input_type = None ; output_type = None ; result }) ; @@ -589,7 +589,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression return (E_constant {cons_name=opname';arguments=lst'}) tv | E_constant {cons_name=C_FOLD_WHILE as opname; arguments = [ - ( { expression_content = (I.E_lambda { binder = lname ; + ( { content = (I.E_lambda { binder = lname ; input_type = None ; output_type = None ; result }) ; @@ -701,7 +701,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression | E_raw_code {language;code} -> let%bind (code,type_expression) = trace_option (expected_ascription code) @@ - I.get_e_ascription code.expression_content in + I.get_e_ascription code.content in let%bind code = type_expression' e code in let%bind type_expression = evaluate_type e type_expression in let code = {code with type_expression} in @@ -740,9 +740,9 @@ and type_lambda e { match input_type with | Some ty -> ok ty | None -> ( - match result.expression_content with + match result.content with | I.E_let_in li -> ( - match li.rhs.expression_content with + match li.rhs.content with | I.E_variable name when name = (binder) -> ( match snd li.let_binder with | Some ty -> ok ty @@ -849,7 +849,7 @@ let rec untype_expression (e:O.expression) : (I.expression , typer_error) result | E_recursive {fun_name;fun_type; lambda} -> let%bind fun_type = untype_type_expression fun_type in let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in - let lambda = match unty_expr.expression_content with I.E_lambda l -> l | _ -> failwith "impossible case" in + let lambda = match unty_expr.content with I.E_lambda l -> l | _ -> failwith "impossible case" in return @@ e_recursive fun_name fun_type lambda and untype_matching : (O.expression -> (I.expression , typer_error) result) -> O.matching_expr -> (I.matching_expr , typer_error) result = fun f m -> diff --git a/src/passes/10-self_ast_typed/helpers.ml b/src/passes/10-self_ast_typed/helpers.ml index a891cdd56..d66c32c98 100644 --- a/src/passes/10-self_ast_typed/helpers.ml +++ b/src/passes/10-self_ast_typed/helpers.ml @@ -256,7 +256,7 @@ type contract_type = { let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program -> let aux declt = match Location.unwrap declt with | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) -> - if String.equal (Var.to_name binder) main_fname + if Var.equal binder @@ Var.of_name main_fname then Some p else None | Declaration_type _ -> None diff --git a/src/passes/predefined/predefined.ml b/src/passes/predefined/predefined.ml index 3701b62ab..03d593820 100644 --- a/src/passes/predefined/predefined.ml +++ b/src/passes/predefined/predefined.ml @@ -47,6 +47,23 @@ module Tree_abstraction = struct | "timestamp" -> Some TC_timestamp | _ -> None + let type_constant_to_string tc = + match tc with + TC_chain_id -> "chain_id" + | TC_unit -> "unit" + | TC_string -> "string" + | TC_bytes -> "bytes" + | TC_nat -> "nat" + | TC_int -> "int" + | TC_mutez -> "tez" + | TC_operation -> "operation" + | TC_address -> "address" + | TC_key -> "key" + | TC_key_hash -> "key_hash" + | TC_signature -> "signature" + | TC_timestamp -> "timestamp" + | TC_void -> "void" + let type_operators s = match s with "list" -> Some (TC_list) @@ -61,6 +78,23 @@ module Tree_abstraction = struct | "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb) | _ -> None + let type_operator_to_string s = + match s with + TC_list -> "list" + | TC_option -> "option" + | TC_set -> "set" + | TC_map -> "map" + | TC_big_map -> "big_map" + | TC_contract -> "contract" + | TC_michelson_pair -> "michelson_pair" + | TC_michelson_or -> "michelson_or" + | TC_michelson_pair_right_comb -> "michelson_pair_right_comb" + | TC_michelson_pair_left_comb -> "michelson_pair_left_comb" + | TC_michelson_or_right_comb -> "michelson_or_right_comb" + | TC_michelson_or_left_comb -> "michelson_or_left_comb" + | TC_map_or_big_map -> "map_or_big_map" + + let pseudo_modules = function | "Tezos.chain_id" -> Some C_CHAIN_ID | "Tezos.balance" -> Some C_BALANCE @@ -165,6 +199,113 @@ module Tree_abstraction = struct | _ -> None + let pseudo_module_to_string = function + | C_CHAIN_ID -> "Tezos.chain_id" + | C_BALANCE -> "Tezos.balance" + | C_NOW -> "Tezos.now" + | C_AMOUNT -> "Tezos.amount" + | C_SENDER -> "Tezos.sender" + | C_ADDRESS -> "Tezos.address" + | C_SELF -> "Tezos.self" + | C_SELF_ADDRESS -> "Tezos.self_address" + | C_IMPLICIT_ACCOUNT -> "Tezos.implicit_account" + | C_SOURCE -> "Tezos.source" + | C_FAILWITH -> "Tezos.failwith" + | C_CREATE_CONTRACT -> "Tezos.create_contract" + | C_CALL -> "Tezos.transaction" + | C_SET_DELEGATE -> "Tezos.set_delegate" + | C_CONTRACT_OPT -> "Tezos.get_contract_opt" + | C_CONTRACT_ENTRYPOINT_OPT -> "Tezos.get_entrypoint_opt" + | C_CONTRACT -> "Tezos.get_contract" + | C_CONTRACT_ENTRYPOINT -> "Tezos.get_entrypoint" + + (* Crypto module *) + + | C_CHECK_SIGNATURE -> "Crypto.check" + | C_HASH_KEY -> "Crypto.hash_key" + | C_BLAKE2b -> "Crypto.blake2b" + | C_SHA256 -> "Crypto.sha256" + | C_SHA512 -> "Crypto.sha512" + + (* Bytes module *) + + | C_BYTES_PACK -> "Bytes.pack" + | C_BYTES_UNPACK -> "Bytes.unpack" + | C_SIZE -> "Bytes.length" + | C_CONCAT -> "Bytes.concat" + | C_SLICE -> "Bytes.sub" + + (* List module *) + + (* | C_SIZE -> "List.size" *) + | C_LIST_ITER -> "List.iter" + | C_LIST_MAP -> "List.map" + | C_LIST_FOLD -> "List.fold" + + (* Set module *) + + | C_SET_EMPTY -> "Set.empty" + | C_SET_LITERAL -> "Set.literal" + (* | C_SIZE -> "Set.cardinal"*) + | C_SET_MEM -> "Set.mem" + | C_SET_ADD -> "Set.add" + | C_SET_REMOVE -> "Set.remove" + | C_SET_ITER -> "Set.iter" + | C_SET_FOLD -> "Set.fold" + + (* Map module *) + + | C_MAP_FIND_OPT -> "Map.find_opt" + | C_MAP_UPDATE -> "Map.update" + | C_MAP_ITER -> "Map.iter" + | C_MAP_MAP -> "Map.map" + | C_MAP_FOLD -> "Map.fold" + | C_MAP_MEM -> "Map.mem" + (* | C_SIZE -> "Map.size" *) + | C_MAP_ADD -> "Map.add" + | C_MAP_REMOVE -> "Map.remove" + | C_MAP_EMPTY -> "Map.empty" + | C_MAP_LITERAL -> "Map.literal" + + (* Big_map module *) + + | C_MAP_FIND -> "Big_map.find" + (* | C_MAP_FIND_OPT -> "Big_map.find_opt" + | C_MAP_UPDATE -> "Big_map.update" *) + | C_BIG_MAP_LITERAL -> "Big_map.literal" + | C_BIG_MAP_EMPTY -> "Big_map.empty" + (* | C_MAP_MEM -> "Big_map.mem" + | C_MAP_REMOVE -> "Big_map.remove" + | C_MAP_ADD -> "Big_map.add" *) + + (* Bitwise module *) + + | C_OR -> "Bitwise.or" + | C_AND -> "Bitwise.and" + | C_XOR -> "Bitwise.xor" + | C_LSL -> "Bitwise.shift_left" + | C_LSR -> "Bitwise.shift_right" + + (* String module *) + + (* | C_SIZE -> "String.length" (* will never trigger, rename size *) + | C_SLICE -> "String.sub" + | C_CONCAT -> "String.concat" *) + + (* michelson pair/or type converter module *) + + | C_CONVERT_TO_RIGHT_COMB -> "Layout.convert_to_right_comb" + | C_CONVERT_TO_LEFT_COMB -> "Layout.convert_to_left_comb" + | C_CONVERT_FROM_RIGHT_COMB -> "Layout.convert_from_right_comb" + | C_CONVERT_FROM_LEFT_COMB -> "Layout.convert_from_left_comb" + + (* Not parsed *) + | C_SOME -> "Some" + | C_NONE -> "None" + + | _ as c -> failwith @@ Format.asprintf "Constant not handled : %a" Stage_common.PP.constant c + + module Pascaligo = struct let constants = function (* Tezos module (ex-Michelson) *) @@ -283,8 +424,46 @@ module Tree_abstraction = struct | _ as c -> pseudo_modules c + let constant_to_string = function + (* Tezos module (ex-Michelson) *) + | C_FAILWITH -> "failwith" + + | C_IS_NAT -> "is_nat" + | C_INT -> "int" + | C_ABS -> "abs" + | C_EDIV -> "ediv" + | C_UNIT -> "unit" + + | C_NEG -> "NEG" + | C_ADD -> "ADD" + | C_SUB -> "SUB" + | C_MUL -> "TIMES" + | C_DIV -> "DIV" + | C_MOD -> "MOD" + | C_EQ -> "EQ" + | C_NOT -> "NOT" + | C_AND -> "AND" + | C_OR -> "OR" + | C_GT -> "GT" + | C_GE -> "GE" + | C_LT -> "LT" + | C_LE -> "LE" + | C_CONS -> "CONS" + | C_NEQ -> "NEQ" + + (*-> Others *) + + | C_ASSERTION -> "assert" + + | C_CONVERT_TO_RIGHT_COMB -> "Layout.convert_to_right_comb" + | C_CONVERT_TO_LEFT_COMB -> "Layout.convert_to_left_comb" + + | _ as c -> pseudo_module_to_string c + let type_constants = type_constants let type_operators = type_operators + let type_constant_to_string = type_constant_to_string + let type_operator_to_string = type_operator_to_string end module Cameligo = struct @@ -370,8 +549,43 @@ module Tree_abstraction = struct | _ as c -> pseudo_modules c + let constant_to_string = function + (* Tezos (ex-Michelson, ex-Current, ex-Operation) *) + | C_FAILWITH -> "failwith" + + | C_IS_NAT -> "is_nat" + | C_INT -> "int" + | C_ABS -> "abs" + | C_EDIV -> "ediv" + | C_UNIT -> "unit" + + | C_NEG -> "NEG" + | C_ADD -> "ADD" + | C_SUB -> "SUB" + | C_MUL -> "TIMES" + | C_DIV -> "DIV" + | C_MOD -> "MOD" + | C_EQ -> "EQ" + | C_NOT -> "NOT" + | C_AND -> "AND" + | C_OR -> "OR" + | C_GT -> "GT" + | C_GE -> "GE" + | C_LT -> "LT" + | C_LE -> "LE" + | C_CONS -> "CONS" + | C_NEQ -> "NEQ" + + (* Others *) + + | C_ASSERTION -> "assert" + + | _ as c -> pseudo_module_to_string c + let type_constants = type_constants let type_operators = type_operators + let type_constant_to_string = type_constant_to_string + let type_operator_to_string = type_operator_to_string end end diff --git a/src/passes/predefined/predefined.mli b/src/passes/predefined/predefined.mli index 15a213ae0..5b99fb9b7 100644 --- a/src/passes/predefined/predefined.mli +++ b/src/passes/predefined/predefined.mli @@ -3,15 +3,21 @@ module Tree_abstraction : sig open Ast_imperative module Pascaligo : sig - val constants : string -> constant' option + val constants : string -> constant' option val type_constants : string -> type_constant option val type_operators : string -> type_operator option + val constant_to_string : constant' -> string + val type_constant_to_string : type_constant -> string + val type_operator_to_string : type_operator -> string end module Cameligo : sig val constants : string -> constant' option val type_constants : string -> type_constant option val type_operators : string -> type_operator option + val constant_to_string : constant' -> string + val type_constant_to_string : type_constant -> string + val type_operator_to_string : type_operator -> string end end diff --git a/src/stages/1-cst/cameligo/CST.ml b/src/stages/1-cst/cameligo/CST.ml index a6002e729..e62ecaf93 100644 --- a/src/stages/1-cst/cameligo/CST.ml +++ b/src/stages/1-cst/cameligo/CST.ml @@ -251,13 +251,13 @@ and expr = and annot_expr = expr * colon * type_expr and 'a injection = { - compound : compound; + compound : compound option; elements : ('a, semi) sepseq; terminator : semi option } and 'a ne_injection = { - compound : compound; + compound : compound option; ne_elements : ('a, semi) nsepseq; terminator : semi option } @@ -395,8 +395,7 @@ and cond_expr = { test : expr; kwd_then : kwd_then; ifso : expr; - kwd_else : kwd_else; - ifnot : expr + ifnot : (kwd_else * expr) option; } (* Code injection. Note how the field [language] wraps a region in diff --git a/src/stages/1-cst/cameligo/ParserLog.ml b/src/stages/1-cst/cameligo/ParserLog.ml index 5331e3e65..b36524f67 100644 --- a/src/stages/1-cst/cameligo/ParserLog.ml +++ b/src/stages/1-cst/cameligo/ParserLog.ml @@ -63,6 +63,11 @@ let print_sepseq : None -> () | Some seq -> print_nsepseq state sep print seq +let print_option : state -> (state -> 'a -> unit ) -> 'a option -> unit = + fun state print -> function + None -> () + | Some opt -> print state opt + let print_csv state print {value; _} = print_nsepseq state "," print value @@ -74,7 +79,7 @@ let print_token state region lexeme = let print_var state {region; value} = let line = sprintf "%s: Ident %s\n" - (compact state region) value + (compact state region)value in Buffer.add_string state#buffer line let print_constr state {region; value} = @@ -244,14 +249,18 @@ and print_ne_injection : print_close_compound state compound and print_open_compound state = function - BeginEnd (kwd_begin,_) -> print_token state kwd_begin "begin" -| Braces (lbrace,_) -> print_token state lbrace "{" -| Brackets (lbracket,_) -> print_token state lbracket "[" + None -> () +| Some compound -> match compound with + BeginEnd (kwd_begin,_) -> print_token state kwd_begin "begin" + | Braces (lbrace,_) -> print_token state lbrace "{" + | Brackets (lbracket,_) -> print_token state lbracket "[" and print_close_compound state = function - BeginEnd (_,kwd_end) -> print_token state kwd_end "end" -| Braces (_,rbrace) -> print_token state rbrace "}" -| Brackets (_,rbracket) -> print_token state rbracket "]" + None -> () +| Some compound -> match compound with + BeginEnd (_,kwd_end) -> print_token state kwd_end "end" + | Braces (_,rbrace) -> print_token state rbrace "}" + | Brackets (_,rbracket) -> print_token state rbracket "]" and print_terminator state = function Some semi -> print_token state semi ";" @@ -584,15 +593,18 @@ and print_fun_expr state {value; _} = and print_conditional state {value; _} = let {kwd_if; test; kwd_then; - ifso; kwd_else; ifnot} = value in - print_token state ghost "("; - print_token state kwd_if "if"; - print_expr state test; - print_token state kwd_then "then"; - print_expr state ifso; - print_token state kwd_else "else"; - print_expr state ifnot; - print_token state ghost ")" + ifso; ifnot} = value in + print_token state ghost "("; + print_token state kwd_if "if"; + print_expr state test; + print_token state kwd_then "then"; + print_expr state ifso; + print_option state + (fun state (kwd_else,ifnot) -> + print_token state kwd_else "else"; + print_expr state ifnot; + ) ifnot; + print_token state ghost ")" (* Conversion to string *) @@ -1114,10 +1126,12 @@ and pp_cond_expr state (cond: cond_expr) = let state = state#pad 3 1 in pp_node state ""; pp_expr (state#pad 1 0) cond.ifso in - let () = + let () = match cond.ifnot with + Some (_, ifnot) -> let state = state#pad 3 2 in pp_node state ""; - pp_expr (state#pad 1 0) cond.ifnot + pp_expr (state#pad 1 0) ifnot + | None -> () in () and pp_case : diff --git a/src/stages/1-cst/pascaligo/CST.ml b/src/stages/1-cst/pascaligo/CST.ml index 21c1d9b12..5315ee73c 100644 --- a/src/stages/1-cst/pascaligo/CST.ml +++ b/src/stages/1-cst/pascaligo/CST.ml @@ -219,12 +219,17 @@ and fun_decl = { param : parameters; ret_type : (colon * type_expr) option; kwd_is : kwd_is; - block_with : (block reg * kwd_with) option; return : expr; terminator : semi option; attributes : attr_decl option } +and block_with = { + block : block reg; + kwd_with : kwd_with; + expr : expr; +} + and parameters = (param_decl, semi) nsepseq par reg and param_decl = @@ -382,15 +387,13 @@ and 'a case_clause = { and assignment = { lhs : lhs; assign : assign; - rhs : rhs + rhs : expr; } and lhs = Path of path | MapPath of map_lookup reg -and rhs = expr - and loop = While of while_loop reg | For of for_loop @@ -465,6 +468,7 @@ and expr = | EPar of expr par reg | EFun of fun_expr reg | ECodeInj of code_inj reg +| EBlock of block_with reg and annot_expr = expr * colon * type_expr @@ -691,7 +695,8 @@ let rec expr_to_region = function | ECond {region; _} | EPar {region; _} | EFun {region; _} -| ECodeInj {region; _} -> region +| ECodeInj {region; _} +| EBlock {region; _} -> region and tuple_expr_to_region {region; _} = region @@ -809,8 +814,6 @@ let lhs_to_region : lhs -> Region.t = function Path path -> path_to_region path | MapPath {region; _} -> region -let rhs_to_region = expr_to_region - let selection_to_region = function FieldName {region; _} | Component {region; _} -> region diff --git a/src/stages/1-cst/pascaligo/ParserLog.ml b/src/stages/1-cst/pascaligo/ParserLog.ml index e33c9be4c..f536133a0 100644 --- a/src/stages/1-cst/pascaligo/ParserLog.ml +++ b/src/stages/1-cst/pascaligo/ParserLog.ml @@ -218,18 +218,13 @@ and print_type_tuple state {value; _} = and print_fun_decl state {value; _} = let {kwd_function; fun_name; param; - ret_type; kwd_is; block_with; + ret_type; kwd_is; return; terminator; _} = value in print_token state kwd_function "function"; print_var state fun_name; print_parameters state param; print_option state print_colon_type_expr ret_type; print_token state kwd_is "is"; - (match block_with with - None -> () - | Some (block, kwd_with) -> - print_block state block; - print_token state kwd_with "with"); print_expr state return; print_terminator state terminator; @@ -252,6 +247,12 @@ and print_code_inj state {value; _} = print_expr state code; print_token state rbracket "]" +and print_block_expr state {value; _} = + let {block;kwd_with;expr} = value in + print_block state block; + print_token state kwd_with "with"; + print_expr state expr; + and print_parameters state {value; _} = let {lpar; inside; rpar} = value in print_token state lpar "("; @@ -475,6 +476,7 @@ and print_expr state = function | EPar e -> print_par_expr state e | EFun e -> print_fun_expr state e | ECodeInj e -> print_code_inj state e +| EBlock e -> print_block_expr state e and print_annot_expr state node = let {inside; _} : annot_expr par = node in @@ -919,11 +921,11 @@ and pp_attr_decl state = pp_ne_injection pp_string state and pp_fun_decl state decl = let arity, start = match decl.kwd_recursive with - None -> 5,0 + None -> 4,0 | Some _ -> - let state = state#pad 6 0 in + let state = state#pad 5 0 in let () = pp_node state "recursive" - in 6,1 in + in 5,1 in let () = let state = state#pad arity start in pp_ident state decl.fun_name in @@ -937,14 +939,6 @@ and pp_fun_decl state decl = print_option (state#pad 1 0) pp_type_expr @@ Option.map snd decl.ret_type in let () = let state = state#pad arity (start + 3) in - pp_node state ""; - let statements = - match decl.block_with with - Some (block,_) -> block.value.statements - | None -> Instr (Skip Region.ghost), [] in - pp_statements state statements in - let () = - let state = state#pad arity (start + 4) in pp_node state ""; pp_expr (state#pad 1 0) decl.return in () @@ -1039,6 +1033,19 @@ and pp_code_inj state rc = pp_expr (state#pad 1 0) rc.code in () +and pp_block_expr state (bw : block_with) = + let {block;expr;_}:CST.block_with = bw in + let () = + let state = state#pad 2 0 in + pp_node state ""; + pp_statements state block.value.statements + in + let () = + let state = state#pad 2 1 in + pp_node state ""; + pp_expr (state#pad 1 0) expr in + () + and pp_parameters state {value; _} = let params = Utils.nsepseq_to_list value.inside in let arity = List.length params in @@ -1521,6 +1528,9 @@ and pp_expr state = function | ECodeInj {value; region} -> pp_loc_node state "ECodeInj" region; pp_code_inj state value; +| EBlock {value; region} -> + pp_loc_node state "EBlock" region; + pp_block_expr state value; and pp_list_expr state = function ECons {value; region} -> diff --git a/src/stages/1-cst/pascaligo/ParserLog.mli b/src/stages/1-cst/pascaligo/ParserLog.mli index af3ab8528..033d4df06 100644 --- a/src/stages/1-cst/pascaligo/ParserLog.mli +++ b/src/stages/1-cst/pascaligo/ParserLog.mli @@ -19,6 +19,7 @@ val print_path : state -> CST.path -> unit val print_pattern : state -> CST.pattern -> unit val print_instruction : state -> CST.instruction -> unit val print_expr : state -> CST.expr -> unit +val print_statements : state -> CST.statements -> unit (** {1 Printing tokens from the CST in a string} *) diff --git a/src/stages/2-ast_imperative/types.ml b/src/stages/2-ast_imperative/types.ml index 4d4766f1f..da334e606 100644 --- a/src/stages/2-ast_imperative/types.ml +++ b/src/stages/2-ast_imperative/types.ml @@ -135,7 +135,7 @@ and matching = and ascription = {anno_expr: expression; type_annotation: type_expression} and conditional = { - condition : expression ; + condition : expression ; then_clause : expression ; else_clause : expression ; } diff --git a/src/stages/4-ast_core/PP.ml b/src/stages/4-ast_core/PP.ml index 4f36e6801..b93108f93 100644 --- a/src/stages/4-ast_core/PP.ml +++ b/src/stages/4-ast_core/PP.ml @@ -2,16 +2,96 @@ open Types open Format open PP_helpers - +module Helpers = Stage_common.Helpers include Stage_common.PP -include Ast_PP_type(Ast_core_parameter) + + + let cmap_sep value sep ppf m = + let lst = CMap.to_kv_list m in + let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in + let new_pp ppf (k, {ctor_type;_}) = fprintf ppf "@[%a -> %a@]" constructor k value ctor_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + let cmap_sep_d x = cmap_sep x (tag " ,@ ") + + let record_sep value sep ppf (m : 'a label_map) = + let lst = LMap.to_kv_list m in + let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in + let new_pp ppf (k, {field_type;_}) = fprintf ppf "@[%a -> %a@]" label k value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let tuple_sep value sep ppf m = + assert (Helpers.is_tuple_lmap m); + let lst = Helpers.tuple_of_record m in + let new_pp ppf (_, {field_type;_}) = fprintf ppf "%a" value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let record_sep_expr value sep ppf (m : 'a label_map) = + let lst = LMap.to_kv_list m in + let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in + let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" label k value v in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let tuple_sep_expr value sep ppf m = + assert (Helpers.is_tuple_lmap m); + let lst = Helpers.tuple_of_record m in + let new_pp ppf (_,v) = fprintf ppf "%a" value v in + fprintf ppf "%a" (list_sep new_pp sep) lst + +(* Prints records which only contain the consecutive fields + 0..(cardinal-1) as tuples *) +let tuple_or_record_sep_t value format_record sep_record format_tuple sep_tuple ppf m = + if Helpers.is_tuple_lmap m then + fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m + else + fprintf ppf format_record (record_sep value (tag sep_record)) m + +let tuple_or_record_sep_expr value format_record sep_record format_tuple sep_tuple ppf m = + if Helpers.is_tuple_lmap m then + fprintf ppf format_tuple (tuple_sep_expr value (tag sep_tuple)) m + else + fprintf ppf format_record (record_sep_expr value (tag sep_record)) m + +let tuple_or_record_sep_expr value = tuple_or_record_sep_expr value "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " +let tuple_or_record_sep_type value = tuple_or_record_sep_t value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " + +let rec type_content : formatter -> type_expression -> unit = + fun ppf te -> + match te.content with + | T_sum m -> fprintf ppf "@[sum[%a]@]" (cmap_sep_d type_expression) m + | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type type_expression) m + | T_arrow a -> fprintf ppf "%a -> %a" type_expression a.type1 type_expression a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator type_expression ppf to_ + +and type_expression ppf (te : type_expression) : unit = + fprintf ppf "%a" type_content te + +and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit = + fun f ppf to_ -> + let s = match to_ with + TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst + | TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst + | TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst + | TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst + | TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst + | TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst + | TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst + | TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst + | TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst + | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst + in + fprintf ppf "(type_operator: %s)" s let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev let rec expression ppf (e : expression) = - expression_content ppf e.expression_content + expression_content ppf e.content and expression_content ppf (ec : expression_content) = match ec with | E_literal l -> @@ -109,10 +189,10 @@ let declaration ppf (d : declaration) = match d with | Declaration_type (type_name, te) -> fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te - | Declaration_constant (name, ty_opt, i, expr) -> + | Declaration_constant (name, ty_opt, attr, expr) -> fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression expr - option_inline i + option_inline attr.inline let program ppf (p : program) = fprintf ppf "@[%a@]" diff --git a/src/stages/4-ast_core/combinators.ml b/src/stages/4-ast_core/combinators.ml index 2e578d27e..46debd9ab 100644 --- a/src/stages/4-ast_core/combinators.ml +++ b/src/stages/4-ast_core/combinators.ml @@ -3,109 +3,108 @@ module Option = Simple_utils.Option module SMap = Map.String -let make_t ?(loc = Location.generated) type_content = {type_content; location=loc; type_meta = ()} +let make_t ?(loc = Location.generated) ?sugar content = ({content; sugar; location=loc}: type_expression) let tuple_to_record lst = let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in let (_, lst ) = List.fold_left aux (0,[]) lst in lst -let t_bool ?loc () : type_expression = make_t ?loc @@ T_variable (Stage_common.Constant.t_bool) -let t_string ?loc () : type_expression = make_t ?loc @@ T_constant (TC_string) -let t_bytes ?loc () : type_expression = make_t ?loc @@ T_constant (TC_bytes) -let t_int ?loc () : type_expression = make_t ?loc @@ T_constant (TC_int) -let t_operation ?loc () : type_expression = make_t ?loc @@ T_constant (TC_operation) -let t_nat ?loc () : type_expression = make_t ?loc @@ T_constant (TC_nat) -let t_tez ?loc () : type_expression = make_t ?loc @@ T_constant (TC_mutez) -let t_unit ?loc () : type_expression = make_t ?loc @@ T_constant (TC_unit) -let t_address ?loc () : type_expression = make_t ?loc @@ T_constant (TC_address) -let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_signature) -let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key) -let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash) -let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp) -let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o]) -let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list, [t]) -let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable (Var.of_name n) -let t_record_ez ?loc lst = +let t_bool ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_variable (Stage_common.Constant.t_bool) +let t_string ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_string) +let t_bytes ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_bytes) +let t_int ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_int) +let t_operation ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_operation) +let t_nat ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_nat) +let t_tez ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_mutez) +let t_unit ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_unit) +let t_address ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_address) +let t_signature ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_signature) +let t_key ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_key) +let t_key_hash ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_key_hash) +let t_timestamp ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_timestamp) +let t_option ?loc ?sugar o : type_expression = make_t ?loc ?sugar @@ T_operator (TC_option, [o]) +let t_list ?loc ?sugar t : type_expression = make_t ?loc ?sugar @@ T_operator (TC_list, [t]) +let t_variable ?loc ?sugar n : type_expression = make_t ?loc ?sugar @@ T_variable (Var.of_name n) +let t_record_ez ?loc ?sugar lst = let lst = List.map (fun (k, v) -> (Label k, v)) lst in let m = LMap.of_list lst in - make_t ?loc @@ T_record m -let t_record ?loc m : type_expression = + make_t ?loc ?sugar @@ T_record m +let t_record ?loc ?sugar m : type_expression = let lst = Map.String.to_kv_list m in - t_record_ez ?loc lst + t_record_ez ?loc ?sugar lst -let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [("0",a) ; ("1",b)] -let t_tuple ?loc lst : type_expression = t_record_ez ?loc (tuple_to_record lst) +let t_pair ?loc ?sugar (a , b) : type_expression = t_record_ez ?loc ?sugar [("0",a) ; ("1",b)] +let t_tuple ?loc ?sugar lst : type_expression = t_record_ez ?loc ?sugar (tuple_to_record lst) -let ez_t_sum ?loc (lst:(string * ctor_content) list) : type_expression = +let ez_t_sum ?loc ?sugar (lst:(string * ctor_content) list) : type_expression = let aux prev (k, v) = CMap.add (Constructor k) v prev in let map = List.fold_left aux CMap.empty lst in - make_t ?loc @@ T_sum map -let t_sum ?loc m : type_expression = + make_t ?loc ?sugar @@ T_sum map +let t_sum ?loc ?sugar m : type_expression = let lst = Map.String.to_kv_list m in - ez_t_sum ?loc lst + ez_t_sum ?loc ?sugar lst -let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2} +let t_function ?loc ?sugar type1 type2 : type_expression = make_t ?loc ?sugar @@ T_arrow {type1; type2} +let t_operator ?loc ?sugar op lst : type_expression = make_t ?loc ?sugar @@ T_operator (op, lst) +let t_map ?loc ?sugar key value : type_expression = make_t ?loc ?sugar @@ T_operator (TC_map, [key; value]) +let t_big_map ?loc ?sugar key value : type_expression = make_t ?loc ?sugar @@ T_operator (TC_big_map, [key; value]) +let t_set ?loc ?sugar key : type_expression = make_t ?loc ?sugar @@ T_operator (TC_set, [key]) +let t_contract ?loc ?sugar contract : type_expression = make_t ?loc ?sugar @@ T_operator (TC_contract, [contract]) -let t_operator ?loc op lst : type_expression = make_t ?loc @@ T_operator (op, lst) -let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map, [key; value]) -let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value]) -let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set, [key]) -let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract]) +let make_e ?(loc = Location.generated) ?sugar content = {content; sugar; location=loc } -let make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc } - -let e_var ?loc (n: string) : expression = make_e ?loc @@ E_variable (Var.of_name n) -let e_literal ?loc l : expression = make_e ?loc @@ E_literal l -let e_unit ?loc () : expression = make_e ?loc @@ E_literal (Literal_unit) -let e_int ?loc n : expression = make_e ?loc @@ E_literal (Literal_int n) -let e_nat ?loc n : expression = make_e ?loc @@ E_literal (Literal_nat n) -let e_timestamp ?loc n : expression = make_e ?loc @@ E_literal (Literal_timestamp n) -let e_string ?loc s : expression = make_e ?loc @@ E_literal (Literal_string s) -let e_address ?loc s : expression = make_e ?loc @@ E_literal (Literal_address s) -let e_mutez ?loc s : expression = make_e ?loc @@ E_literal (Literal_mutez s) -let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signature s) -let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s) -let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s) -let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s) +let e_var ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_variable (Var.of_name n) +let e_literal ?loc ?sugar l : expression = make_e ?loc ?sugar @@ E_literal l +let e_unit ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_literal (Literal_unit) +let e_int ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_int n) +let e_nat ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_nat n) +let e_timestamp ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_timestamp n) +let e_string ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_string s) +let e_address ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_address s) +let e_mutez ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_mutez s) +let e_signature ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_signature s) +let e_key ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_key s) +let e_key_hash ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_key_hash s) +let e_chain_id ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_literal (Literal_chain_id s) let e'_bytes b : expression_content = let bytes = Hex.to_bytes (`Hex b) in E_literal (Literal_bytes bytes) -let e_bytes_hex ?loc b : expression = +let e_bytes_hex ?loc ?sugar b : expression = let e' = e'_bytes b in - make_e ?loc e' -let e_bytes_raw ?loc (b: bytes) : expression = - make_e ?loc @@ E_literal (Literal_bytes b) -let e_bytes_string ?loc (s: string) : expression = - make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) -let e_some ?loc s : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} -let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []} -let e_string_cat ?loc sl sr : expression = make_e ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} -let e_map_add ?loc k v old : expression = make_e ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} + make_e ?loc ?sugar e' +let e_bytes_raw ?loc ?sugar (b: bytes) : expression = + make_e ?loc ?sugar @@ E_literal (Literal_bytes b) +let e_bytes_string ?loc ?sugar (s: string) : expression = + make_e ?loc ?sugar @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) +let e_some ?loc ?sugar s : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_SOME; arguments = [s]} +let e_none ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_NONE; arguments = []} +let e_string_cat ?loc ?sugar sl sr : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} +let e_map_add ?loc ?sugar k v old : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} -let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst} -let e_variable ?loc v = make_e ?loc @@ E_variable v -let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b} -let e_lambda ?loc binder input_type output_type result = make_e ?loc @@ E_lambda {binder; input_type; output_type; result ; } -let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda} -let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } -let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code} +let e_constant ?loc ?sugar name lst = make_e ?loc ?sugar @@ E_constant {cons_name=name ; arguments = lst} +let e_variable ?loc ?sugar v = make_e ?loc ?sugar @@ E_variable v +let e_application ?loc ?sugar a b = make_e ?loc ?sugar @@ E_application {lamb=a ; args=b} +let e_lambda ?loc ?sugar binder input_type output_type result = make_e ?loc ?sugar @@ E_lambda {binder; input_type; output_type; result ; } +let e_recursive ?loc ?sugar fun_name fun_type lambda = make_e ?loc ?sugar @@ E_recursive {fun_name; fun_type; lambda} +let e_let_in ?loc ?sugar (binder, ascr) inline rhs let_result = make_e ?loc ?sugar @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } +let e_raw_code ?loc ?sugar language code = make_e ?loc ?sugar @@ E_raw_code {language; code} -let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} -let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} +let e_constructor ?loc ?sugar s a : expression = make_e ?loc ?sugar @@ E_constructor { constructor = Constructor s; element = a} +let e_matching ?loc ?sugar a b : expression = make_e ?loc ?sugar @@ E_matching {matchee=a;cases=b} -let e_record ?loc map = make_e ?loc @@ E_record map -let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = b} -let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update} +let e_record ?loc ?sugar map = make_e ?loc ?sugar @@ E_record map +let e_record_accessor ?loc ?sugar a b = make_e ?loc ?sugar @@ E_record_accessor {record = a; path = b} +let e_record_update ?loc ?sugar record path update = make_e ?loc ?sugar @@ E_record_update {record; path; update} -let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_annotation ?loc ?sugar anno_expr ty = make_e ?loc ?sugar @@ E_ascription {anno_expr; type_annotation = ty} -let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit ()) +let e_bool ?loc ?sugar b : expression = e_constructor ?loc ?sugar (string_of_bool b) (e_unit ()) -let make_option_typed ?loc e t_opt = +let make_option_typed ?loc ?sugar e t_opt = match t_opt with | None -> e - | Some t -> e_annotation ?loc e t + | Some t -> e_annotation ?loc ?sugar e t let e_typed_none ?loc t_opt = let type_annotation = t_option t_opt in @@ -139,7 +138,7 @@ let get_e_list = fun t -> let rec aux t = match t with E_constant {cons_name=C_CONS;arguments=[key;lst]} -> - let lst = aux lst.expression_content in + let lst = aux lst.content in (Some key)::(lst) | E_constant {cons_name=C_LIST_EMPTY;arguments=[]} -> [] @@ -161,7 +160,7 @@ let get_e_ascription = fun a -> (* Same as get_e_pair *) let extract_pair : expression -> (expression * expression) option = fun e -> - match e.expression_content with + match e.content with | E_record r -> ( let lst = LMap.to_kv_list r in match lst with @@ -173,13 +172,13 @@ let extract_pair : expression -> (expression * expression) option = fun e -> | _ -> None let extract_record : expression -> (label * expression) list option = fun e -> - match e.expression_content with + match e.content with | E_record lst -> Some (LMap.to_kv_list lst) | _ -> None let extract_map : expression -> (expression * expression) list option = fun e -> let rec aux e = - match e.expression_content with + match e.content with E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} -> let map = aux map in (Some (k,v))::map diff --git a/src/stages/4-ast_core/combinators.mli b/src/stages/4-ast_core/combinators.mli index 63a5da2a8..c30373c19 100644 --- a/src/stages/4-ast_core/combinators.mli +++ b/src/stages/4-ast_core/combinators.mli @@ -1,86 +1,86 @@ open Types -val make_t : ?loc:Location.t -> type_content -> type_expression -val t_bool : ?loc:Location.t -> unit -> type_expression -val t_string : ?loc:Location.t -> unit -> type_expression -val t_bytes : ?loc:Location.t -> unit -> type_expression -val t_int : ?loc:Location.t -> unit -> type_expression -val t_operation : ?loc:Location.t -> unit -> type_expression -val t_nat : ?loc:Location.t -> unit -> type_expression -val t_tez : ?loc:Location.t -> unit -> type_expression -val t_unit : ?loc:Location.t -> unit -> type_expression -val t_address : ?loc:Location.t -> unit -> type_expression -val t_key : ?loc:Location.t -> unit -> type_expression -val t_key_hash : ?loc:Location.t -> unit -> type_expression -val t_timestamp : ?loc:Location.t -> unit -> type_expression -val t_signature : ?loc:Location.t -> unit -> type_expression +val make_t : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_content -> type_expression +val t_bool : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_string : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_bytes : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_int : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_operation : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_nat : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_tez : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_unit : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_address : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_key : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_key_hash : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_timestamp : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression +val t_signature : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression (* val t_option : type_expression -> type_expression *) -val t_list : ?loc:Location.t -> type_expression -> type_expression -val t_variable : ?loc:Location.t -> string -> type_expression +val t_list : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression +val t_variable : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> string -> type_expression (* val t_record : te_map -> type_expression *) -val t_pair : ?loc:Location.t -> ( field_content * field_content ) -> type_expression -val t_tuple : ?loc:Location.t -> field_content list -> type_expression +val t_pair : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> ( field_content * field_content ) -> type_expression +val t_tuple : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> field_content list -> type_expression -val t_record : ?loc:Location.t -> field_content Map.String.t -> type_expression -val t_record_ez : ?loc:Location.t -> (string * field_content) list -> type_expression +val t_record : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> field_content Map.String.t -> type_expression +val t_record_ez : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> (string * field_content) list -> type_expression -val t_sum : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expression -val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression +val t_sum : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> Types.ctor_content Map.String.t -> type_expression +val ez_t_sum : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> ( string * Types.ctor_content ) list -> type_expression -val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression +val t_function : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression -val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression -val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression -val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression -val t_contract : ?loc:Location.t -> type_expression -> type_expression -val t_set : ?loc:Location.t -> type_expression -> type_expression +val t_operator : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_operator -> type_expression list -> type_expression +val t_map : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression +val t_big_map : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression +val t_contract : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression +val t_set : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -val make_e : ?loc:Location.t -> expression_content -> expression -val e_var : ?loc:Location.t -> string -> expression -val e_literal : ?loc:Location.t -> literal -> expression -val e_unit : ?loc:Location.t -> unit -> expression -val e_int : ?loc:Location.t -> Z.t -> expression -val e_nat : ?loc:Location.t -> Z.t -> expression -val e_timestamp : ?loc:Location.t -> Z.t -> expression -val e_bool : ?loc:Location.t -> bool -> expression -val e_string : ?loc:Location.t -> ligo_string -> expression -val e_address : ?loc:Location.t -> string -> expression -val e_signature : ?loc:Location.t -> string -> expression -val e_key : ?loc:Location.t -> string -> expression -val e_key_hash : ?loc:Location.t -> string -> expression -val e_chain_id : ?loc:Location.t -> string -> expression -val e_mutez : ?loc:Location.t -> Z.t -> expression -val e'_bytes : string -> expression_content -val e_bytes_hex : ?loc:Location.t -> string -> expression -val e_bytes_raw : ?loc:Location.t -> bytes -> expression -val e_bytes_string : ?loc:Location.t -> string -> expression +val make_e : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_content -> expression +val e_var : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_literal : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> literal -> expression +val e_unit : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> unit -> expression +val e_int : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression +val e_nat : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression +val e_timestamp : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression +val e_bool : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> bool -> expression +val e_string : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> ligo_string -> expression +val e_address : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_signature : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_key : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_key_hash : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_chain_id : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_mutez : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression +val e'_bytes : string -> expression_content +val e_bytes_hex : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression +val e_bytes_raw : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> bytes -> expression +val e_bytes_string : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -val e_some : ?loc:Location.t -> expression -> expression -val e_none : ?loc:Location.t -> unit -> expression -val e_string_cat : ?loc:Location.t -> expression -> expression -> expression -val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_constructor : ?loc:Location.t -> string -> expression -> expression -val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression -val e_record_accessor : ?loc:Location.t -> expression -> label -> expression -val e_variable : ?loc:Location.t -> expression_variable -> expression -val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression -val e_raw_code : ?loc:Location.t -> string -> expression -> expression -val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression -val e_application : ?loc:Location.t -> expression -> expression -> expression -val e_constant : ?loc:Location.t -> constant' -> expression list -> expression +val e_some : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression +val e_none : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> unit -> expression +val e_string_cat : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression +val e_map_add : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression -> expression +val e_constructor : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -> expression +val e_matching : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> matching_expr -> expression +val e_record_accessor : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> label -> expression +val e_variable : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> expression +val e_let_in : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression +val e_raw_code : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -> expression +val e_annotation : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> type_expression -> expression +val e_application : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression +val e_constant : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> constant' -> expression list -> expression -val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression +val make_option_typed : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> type_expression option -> expression -val e_typed_none : ?loc:Location.t -> type_expression -> expression +val e_typed_none : ?loc:Location.t -> type_expression -> expression -val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression -val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression -val e_record : ?loc:Location.t -> expr label_map-> expression -val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression +val e_lambda : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> type_expression option -> type_expression option -> expression -> expression +val e_recursive : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> type_expression -> lambda -> expression +val e_record : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expr label_map-> expression +val e_record_update : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> label -> expression -> expression val assert_e_record_accessor : expression_content -> unit option diff --git a/src/stages/4-ast_core/dune b/src/stages/4-ast_core/dune index ce45b1899..f1fe26726 100644 --- a/src/stages/4-ast_core/dune +++ b/src/stages/4-ast_core/dune @@ -5,6 +5,7 @@ simple-utils tezos-utils stage_common + ast_sugar ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/stages/4-ast_core/misc.ml b/src/stages/4-ast_core/misc.ml index 239e08c35..20c659552 100644 --- a/src/stages/4-ast_core/misc.ml +++ b/src/stages/4-ast_core/misc.ml @@ -97,7 +97,7 @@ let assert_literal_eq (a, b : literal * literal) : unit option = | Literal_chain_id _, _ -> None let rec assert_value_eq (a, b: (expression * expression )) : unit option = - match (a.expression_content , b.expression_content) with + match (a.content , b.content) with | E_literal a , E_literal b -> assert_literal_eq (a, b) | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> ( diff --git a/src/stages/4-ast_core/types.ml b/src/stages/4-ast_core/types.ml index 43ba9c5c8..d4f809394 100644 --- a/src/stages/4-ast_core/types.ml +++ b/src/stages/4-ast_core/types.ml @@ -2,15 +2,11 @@ module Location = Simple_utils.Location -module Ast_core_parameter = struct - type type_meta = unit -end - include Stage_common.Types -include Ast_generic_type (Ast_core_parameter) - -type inline = bool +type attribute = { + inline: bool +} type program = declaration Location.wrap list and declaration = | Declaration_type of (type_variable * type_expression) @@ -20,10 +16,35 @@ and declaration = * an optional type annotation * a boolean indicating whether it should be inlined * an expression *) - | Declaration_constant of (expression_variable * type_expression option * inline * expression) + | Declaration_constant of (expression_variable * type_expression option * attribute * expression) (* | Macro_declaration of macro_declaration *) -and expression = {expression_content: expression_content; location: Location.t} + + +and type_content = + | T_sum of ctor_content constructor_map + | T_record of field_content label_map + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of (type_operator * type_expression list) + +and arrow = {type1: type_expression; type2: type_expression} +and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int} +and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int} + +and type_expression = { + content : type_content; + sugar : Ast_sugar.type_expression option; + location : Location.t; + } + + +and expression = { + content : expression_content; + sugar : Ast_sugar.expression option; + location : Location.t + } and expression_content = (* Base *) diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index cf9ad3817..aad02eeeb 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -52,7 +52,6 @@ end module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct open PARAMETER - type michelson_annotation = string type type_content = | T_sum of ctor_content constructor_map diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml index feb4a2054..03a410b38 100644 --- a/src/stages/ligo_interpreter/PP.ml +++ b/src/stages/ligo_interpreter/PP.ml @@ -34,7 +34,7 @@ let rec pp_value : value -> string = function let pp_env : env -> unit = fun env -> let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in let () = Env.iter (fun var v -> - Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v)) + Format.printf "\t%a -> %s\n" Var.pp var (pp_value v)) env in let () = Format.printf "\n}\n" in () diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index da0bcdd50..a699035ad 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -96,9 +96,9 @@ module Substitution = struct | Ast_core.T_constant constant -> ok @@ Ast_core.T_constant constant - and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {type_content;location;type_meta} -> - let%bind type_content = s_abstr_type_content ~substs type_content in - ok @@ Ast_core.{type_content;location;type_meta} + and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {content;sugar;location} -> + let%bind content = s_abstr_type_content ~substs content in + ok @@ (Ast_core.{content;sugar;location} : Ast_core.type_expression) and s_type_expression : (T.type_expression,_) w = fun ~substs { type_content; location; type_meta } -> let%bind type_content = s_type_content ~substs type_content in diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index f37a06910..f0964e7fd 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -221,10 +221,10 @@ let sell () = in let make_expecter : int -> Ast_core.expression -> (unit,_) result = fun n result -> let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ - Ast_core.get_e_pair result.expression_content in + Ast_core.get_e_pair result.content in let%bind () = let%bind lst = trace_option (test_internal __LOC__) @@ - Ast_core.get_e_list ops.expression_content in + Ast_core.get_e_list ops.content in Assert.assert_list_size (test_internal __LOC__) lst 1 in let expected_storage = let cards = List.hds @@ cards_ez first_owner n in diff --git a/src/test/contracts/expected/FA1.2.ligo.expected b/src/test/contracts/expected/FA1.2.ligo.expected index f348fa651..998fe6c17 100644 --- a/src/test/contracts/expected/FA1.2.ligo.expected +++ b/src/test/contracts/expected/FA1.2.ligo.expected @@ -31,10 +31,8 @@ type getBalance is type getTotalSupply is record [callback : contract (nat)] type action is - Transfer of transfer - | Approve of approve - | GetAllowance of getAllowance - | GetBalance of getBalance + Transfer of transfer | Approve of approve + | GetAllowance of getAllowance | GetBalance of getBalance | GetTotalSupply of getTotalSupply function transfer (const p : transfer; const s : storage) diff --git a/src/test/contracts/expected/FA1.2.mligo.expected b/src/test/contracts/expected/FA1.2.mligo.expected index 5d8ea43fe..2719b64df 100644 --- a/src/test/contracts/expected/FA1.2.mligo.expected +++ b/src/test/contracts/expected/FA1.2.mligo.expected @@ -24,10 +24,8 @@ type getBalance = {owner : address; callback : nat contract} type getTotalSupply = {callback : nat contract} type action = - Transfer of transfer -| Approve of approve -| GetAllowance of getAllowance -| GetBalance of getBalance + Transfer of transfer | Approve of approve +| GetAllowance of getAllowance | GetBalance of getBalance | GetTotalSupply of getTotalSupply let transfer (p, s : transfer * storage) @@ -42,42 +40,40 @@ let transfer (p, s : transfer * storage) s.allowances with Some value -> value - | None -> 0n - in if (authorized_value < p.value) - then (failwith "Not Enough Allowance" : allowances) - else - Big_map.update - (Tezos.sender, p.address_from) - (Some (abs (authorized_value - p.value))) - s.allowances - in let sender_balance = - match Big_map.find_opt p.address_from s.tokens with - Some value -> value - | None -> 0n - in if (sender_balance < p.value) - then - (failwith "Not Enough Balance" - : operation list * storage) - else - let new_tokens = - Big_map.update - p.address_from - (Some (abs (sender_balance - p.value))) - s.tokens - in let receiver_balance = - match Big_map.find_opt p.address_to s.tokens - with - Some value -> value - | None -> 0n - in let new_tokens = - Big_map.update - p.address_to - (Some (receiver_balance + p.value)) - new_tokens - in ([] : operation list), - {s with - tokens = new_tokens; - allowances = new_allowances} + | None -> 0n in + if (authorized_value < p.value) + then (failwith "Not Enough Allowance" : allowances) + else + Big_map.update + (Tezos.sender, p.address_from) + (Some (abs (authorized_value - p.value))) + s.allowances in + let sender_balance = + match Big_map.find_opt p.address_from s.tokens with + Some value -> value + | None -> 0n in + if (sender_balance < p.value) + then + (failwith "Not Enough Balance" + : operation list * storage) + else + let new_tokens = + Big_map.update + p.address_from + (Some (abs (sender_balance - p.value))) + s.tokens in + let receiver_balance = + match Big_map.find_opt p.address_to s.tokens with + Some value -> value + | None -> 0n in + let new_tokens = + Big_map.update + p.address_to + (Some (receiver_balance + p.value)) + new_tokens in + ([] : operation list), + {s with + tokens = new_tokens; allowances = new_allowances} let approve (p, s : approve * storage) : operation list * storage = @@ -87,20 +83,20 @@ let approve (p, s : approve * storage) s.allowances with Some value -> value - | None -> 0n - in if previous_value > 0n && p.value > 0n - then - (failwith "Unsafe Allowance Change" - : operation list * storage) - else - let new_allowances = - Big_map.update - (p.spender, Tezos.sender) - (Some (p.value)) - s.allowances - in ([] : operation list), - {s with - allowances = new_allowances} + | None -> 0n in + if previous_value > 0n && p.value > 0n + then + (failwith "Unsafe Allowance Change" + : operation list * storage) + else + let new_allowances = + Big_map.update + (p.spender, Tezos.sender) + (Some (p.value)) + s.allowances in + ([] : operation list), + {s with + allowances = new_allowances} let getAllowance (p, s : getAllowance * storage) : operation list * storage = @@ -108,24 +104,24 @@ let getAllowance (p, s : getAllowance * storage) match Big_map.find_opt (p.owner, p.spender) s.allowances with Some value -> value - | None -> 0n - in let op = Tezos.transaction value 0mutez p.callback - in ([op], s) + | None -> 0n in + let op = Tezos.transaction value 0mutez p.callback in + ([op], s) let getBalance (p, s : getBalance * storage) : operation list * storage = let value = match Big_map.find_opt p.owner s.tokens with Some value -> value - | None -> 0n - in let op = Tezos.transaction value 0mutez p.callback - in ([op], s) + | None -> 0n in + let op = Tezos.transaction value 0mutez p.callback in + ([op], s) let getTotalSupply (p, s : getTotalSupply * storage) : operation list * storage = - let total = s.total_amount - in let op = Tezos.transaction total 0mutez p.callback - in ([op], s) + let total = s.total_amount in + let op = Tezos.transaction total 0mutez p.callback in + ([op], s) let main (a, s : action * storage) = match a with diff --git a/src/test/contracts/expected/address.mligo.expected b/src/test/contracts/expected/address.mligo.expected index e4d873bbe..1d2b85c0d 100644 --- a/src/test/contracts/expected/address.mligo.expected +++ b/src/test/contracts/expected/address.mligo.expected @@ -1,3 +1,3 @@ let main (p : key_hash) = - let c : unit contract = Tezos.implicit_account p - in Tezos.address c + let c : unit contract = Tezos.implicit_account p in + Tezos.address c diff --git a/src/test/contracts/expected/amount_lambda.mligo.expected b/src/test/contracts/expected/amount_lambda.mligo.expected index a9d51b22d..98c698e08 100644 --- a/src/test/contracts/expected/amount_lambda.mligo.expected +++ b/src/test/contracts/expected/amount_lambda.mligo.expected @@ -1,6 +1,6 @@ let f1 (x : unit) : unit -> tez = - let amt : tez = Current.amount - in fun (x : unit) -> amt + let amt : tez = Current.amount in + fun (x : unit) -> amt let f2 (x : unit) : unit -> tez = fun (x : unit) -> Current.amount diff --git a/src/test/contracts/expected/assert.mligo.expected b/src/test/contracts/expected/assert.mligo.expected index 41785c58d..e1618f45d 100644 --- a/src/test/contracts/expected/assert.mligo.expected +++ b/src/test/contracts/expected/assert.mligo.expected @@ -1,3 +1,3 @@ let main (p, s : bool * unit) = - let u : unit = assert p - in ([] : operation list), s + let u : unit = assert p in + ([] : operation list), s diff --git a/src/test/contracts/expected/attributes.mligo.expected b/src/test/contracts/expected/attributes.mligo.expected index 0623ef077..cde96edae 100644 --- a/src/test/contracts/expected/attributes.mligo.expected +++ b/src/test/contracts/expected/attributes.mligo.expected @@ -1,8 +1,8 @@ let x = 1 [@@inline] let foo (a : int) : int = - (let test = 2 + a [@@inline] - in test) [@@inline] + (let test = 2 + a [@@inline] in + test) [@@inline] let y = 1 [@@inline][@@other] @@ -10,5 +10,5 @@ let bar (b : int) : int = let test = fun (z : int) -> 2 + b + z [@@inline] [@@foo] - [@@bar] - in test b + [@@bar] in + test b diff --git a/src/test/contracts/expected/big_map.mligo.expected b/src/test/contracts/expected/big_map.mligo.expected index 36eafe0fd..81a61a38d 100644 --- a/src/test/contracts/expected/big_map.mligo.expected +++ b/src/test/contracts/expected/big_map.mligo.expected @@ -18,5 +18,5 @@ let map1 : foo = Big_map.literal [(23, 0); (42, 0)] let map1 : foo = Big_map.literal [(23, 0); (42, 0)] let mutimaps (m : foo) (n : foo) : foo = - let bar : foo = Big_map.update 42 (Some 0) m - in Big_map.update 42 (get bar) n + let bar : foo = Big_map.update 42 (Some 0) m in + Big_map.update 42 (get bar) n diff --git a/src/test/contracts/expected/bytes_unpack.mligo.expected b/src/test/contracts/expected/bytes_unpack.mligo.expected index 74bceb409..56028af77 100644 --- a/src/test/contracts/expected/bytes_unpack.mligo.expected +++ b/src/test/contracts/expected/bytes_unpack.mligo.expected @@ -1,11 +1,11 @@ let id_string (p : string) : string option = - let packed : bytes = Bytes.pack p - in (Bytes.unpack packed : string option) + let packed : bytes = Bytes.pack p in + (Bytes.unpack packed : string option) let id_int (p : int) : int option = - let packed : bytes = Bytes.pack p - in (Bytes.unpack packed : int option) + let packed : bytes = Bytes.pack p in + (Bytes.unpack packed : int option) let id_address (p : address) : address option = - let packed : bytes = Bytes.pack p - in (Bytes.unpack packed : address option) + let packed : bytes = Bytes.pack p in + (Bytes.unpack packed : address option) diff --git a/src/test/contracts/expected/closure.mligo.expected b/src/test/contracts/expected/closure.mligo.expected index a0505ca8f..2ba263209 100644 --- a/src/test/contracts/expected/closure.mligo.expected +++ b/src/test/contracts/expected/closure.mligo.expected @@ -1,5 +1,5 @@ let test (k : int) : int = - let j : int = k + 5 - in let close : int -> int = fun (i : int) -> i + j - in let j : int = 20 - in close 20 + let j : int = k + 5 in + let close : int -> int = fun (i : int) -> i + j in + let j : int = 20 in + close 20 diff --git a/src/test/contracts/expected/condition-shadowing.mligo.expected b/src/test/contracts/expected/condition-shadowing.mligo.expected index b704abaef..38b4e77cf 100644 --- a/src/test/contracts/expected/condition-shadowing.mligo.expected +++ b/src/test/contracts/expected/condition-shadowing.mligo.expected @@ -1,9 +1,9 @@ let main (i : int) = - let result = 0 - in if i = 2 - then - let result = 42 - in result - else - let result = 0 - in result + let result = 0 in + if i = 2 + then + let result = 42 in + result + else + let result = 0 in + result diff --git a/src/test/contracts/expected/create_contract.mligo.expected b/src/test/contracts/expected/create_contract.mligo.expected index ea091b05c..6cec484cc 100644 --- a/src/test/contracts/expected/create_contract.mligo.expected +++ b/src/test/contracts/expected/create_contract.mligo.expected @@ -7,5 +7,5 @@ let main (action, store : string * string) : return = (([] : operation list), "one")) (None : key_hash option) 300000000mutez - "un" - in ([toto.0], store) + "un" in + ([toto.0], store) diff --git a/src/test/contracts/expected/double_michelson_or.mligo.expected b/src/test/contracts/expected/double_michelson_or.mligo.expected index 756e5acba..4e3e321ad 100644 --- a/src/test/contracts/expected/double_michelson_or.mligo.expected +++ b/src/test/contracts/expected/double_michelson_or.mligo.expected @@ -5,6 +5,6 @@ type foobar = (int, "baz", int, "fooo") michelson_or type return = operation list * storage let main (action, store : unit * storage) : return = - let foo = (M_right ("one") : storage) - in let bar = (M_right 1 : foobar) - in (([] : operation list), (foo : storage)) + let foo = (M_right ("one") : storage) in + let bar = (M_right 1 : foobar) in + (([] : operation list), (foo : storage)) diff --git a/src/test/contracts/expected/fibo.mligo.expected b/src/test/contracts/expected/fibo.mligo.expected index 221fe266a..49195edb2 100644 --- a/src/test/contracts/expected/fibo.mligo.expected +++ b/src/test/contracts/expected/fibo.mligo.expected @@ -9,5 +9,5 @@ let main (p, store : unit * storage) f (y, x)) (fun (x : int) (y : int) -> x + y) 0 - 1 - in ([] : operation list), store + 1 in + ([] : operation list), store diff --git a/src/test/contracts/expected/fibo2.mligo.expected b/src/test/contracts/expected/fibo2.mligo.expected index bfa744d14..e4373512c 100644 --- a/src/test/contracts/expected/fibo2.mligo.expected +++ b/src/test/contracts/expected/fibo2.mligo.expected @@ -6,5 +6,5 @@ let main (p, store : unit * storage) (fun (f : int -> int) (z : int) (y : int) -> f y) (fun (x : int) -> x) 0 - 1 - in ([] : operation list), store + 1 in + ([] : operation list), store diff --git a/src/test/contracts/expected/fibo3.mligo.expected b/src/test/contracts/expected/fibo3.mligo.expected index 3f9cc0e83..de9892961 100644 --- a/src/test/contracts/expected/fibo3.mligo.expected +++ b/src/test/contracts/expected/fibo3.mligo.expected @@ -8,5 +8,5 @@ let main (p, s : unit * storage) : operation list * storage = f y (x + y)) (fun (x : int) (y : int) -> x + y) 0 - 1 - in ([] : operation list), store + 1 in + ([] : operation list), store diff --git a/src/test/contracts/expected/guess_string.mligo.expected b/src/test/contracts/expected/guess_string.mligo.expected index 642fdb343..08b213846 100644 --- a/src/test/contracts/expected/guess_string.mligo.expected +++ b/src/test/contracts/expected/guess_string.mligo.expected @@ -10,8 +10,8 @@ let attempt (p, store : param * storage) : return = : unit contract option) with Some contract -> contract - | None -> (failwith "No contract" : unit contract) - in let transfer : operation = - Tezos.transaction (unit, contract, 10000000mutez) - in let store : storage = {challenge = p.new_challenge} - in ([] : operation list), store + | None -> (failwith "No contract" : unit contract) in + let transfer : operation = + Tezos.transaction (unit, contract, 10000000mutez) in + let store : storage = {challenge = p.new_challenge} in + ([] : operation list), store diff --git a/src/test/contracts/expected/id.ligo.expected b/src/test/contracts/expected/id.ligo.expected index d5a8b2b39..fcd9b4f4b 100644 --- a/src/test/contracts/expected/id.ligo.expected +++ b/src/test/contracts/expected/id.ligo.expected @@ -23,10 +23,8 @@ type update_details is ] type action is - Buy of buy - | Update_owner of update_owner - | Update_details of update_details - | Skip of unit + Buy of buy | Update_owner of update_owner + | Update_details of update_details | Skip of unit type storage is record [ diff --git a/src/test/contracts/expected/multisig-v2.ligo.expected b/src/test/contracts/expected/multisig-v2.ligo.expected index 3690c90a7..04fd7af3d 100644 --- a/src/test/contracts/expected/multisig-v2.ligo.expected +++ b/src/test/contracts/expected/multisig-v2.ligo.expected @@ -34,8 +34,7 @@ type default_pt is unit type return is list (operation) * storage type parameter is - Send of send_pt - | Withdraw of withdraw_pt + Send of send_pt | Withdraw of withdraw_pt | Default of default_pt function send (const param : send_pt; const s : storage) diff --git a/src/test/contracts/expected/time-lock.ligo.expected b/src/test/contracts/expected/time-lock.ligo.expected index 96f6c1c4d..dcfb5688e 100644 --- a/src/test/contracts/expected/time-lock.ligo.expected +++ b/src/test/contracts/expected/time-lock.ligo.expected @@ -9,8 +9,7 @@ type call_pt is message_t type contract_return_t is list (operation) * storage_t type entry_point_t is - Call of call_pt - | Default of default_pt + Call of call_pt | Default of default_pt function call (const p : call_pt; const s : storage_t) : contract_return_t is diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 26bc9c6fc..ef1e1985f 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -2096,9 +2096,9 @@ let get_contract_ligo () : (unit, _) result = let%bind () = let make_input = fun _n -> e_unit () in let make_expected : int -> Ast_core.expression -> (unit, _) result = fun _n result -> - let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.expression_content in + let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.content in let%bind () = - let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.expression_content in + let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.content in Assert.assert_list_size (test_internal __LOC__) lst 1 in let expected_storage = Ast_core.e_unit () in trace_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (expected_storage , storage) diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index ca68a94b9..16b18178d 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -112,7 +112,7 @@ let run_typed_program_with_imperative_input ?options (input: Ast_imperative.expression) : (Ast_core.expression, _) result = let%bind michelson_program = typed_program_with_imperative_input_to_michelson (program , state) entry_point input in let%bind michelson_output = Ligo.Run.Of_michelson.run_no_failwith ?options michelson_program.expr michelson_program.expr_ty in - let%bind res = Uncompile.uncompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in + let%bind res = Decompile.Of_michelson.decompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in match res with | Runned_result.Success exp -> ok exp | Runned_result.Fail _ -> fail test_not_expected_to_fail @@ -155,7 +155,7 @@ let expect_evaluate (program, _state) entry_point expecter = let%bind (exp,_) = trace_option unknown @@ Mini_c.get_entry mini_c entry_point in let%bind michelson_value = Ligo.Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in let%bind res_michelson = Ligo.Run.Of_michelson.run_no_failwith michelson_value.expr michelson_value.expr_ty in - let%bind res = Uncompile.uncompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in + let%bind res = Decompile.Of_michelson.decompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in let%bind res' = match res with | Runned_result.Success exp -> ok exp | Runned_result.Fail _ -> fail test_not_expected_to_fail in diff --git a/src/test/time_lock_repeat_tests.ml b/src/test/time_lock_repeat_tests.ml index cab060c1c..06061c25d 100644 --- a/src/test/time_lock_repeat_tests.ml +++ b/src/test/time_lock_repeat_tests.ml @@ -54,7 +54,7 @@ let early_call () = expect_string_failwith ~options (program, state) "main" (e_pair (e_unit ()) init_storage) exp_failwith -let fake_uncompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]" +let fake_decompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]" (* Test that when we use the contract the next use time advances by correct interval *) let interval_advance () = @@ -64,7 +64,7 @@ let interval_advance () = let init_storage = storage lock_time 86400 empty_message in (* It takes a second for Tezos.now to be called, awful hack *) let%bind new_timestamp = mk_time "2000-01-02T10:10:11Z" in - let new_storage_fake = storage new_timestamp 86400 fake_uncompiled_empty_message in + let new_storage_fake = storage new_timestamp 86400 fake_decompiled_empty_message in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in expect_eq ~options (program, state) "main" diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index ff825eb60..9728a6e50 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -345,6 +345,10 @@ let trace_assert_fail_option error = function [let%bind lst' = bind_map_list f lst]. Same thing with folds. *) +let bind_compose f g x = + let%bind y = g x in + f y + let bind_map_option f = function None -> ok None | Some s -> f s >>? fun x -> ok (Some x) diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 38e48ff21..de514a1ff 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -216,5 +216,6 @@ module Ne = struct match f hd with | Some x -> Some x | None -> find_map f tl + let append : 'a t -> 'a t -> 'a t = fun (hd, tl) (hd', tl') -> hd, List.append tl @@ hd' :: tl' end