diff --git a/src/bin/cli.ml b/src/bin/cli.ml index ad36e987c..2a1f21744 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -140,7 +140,9 @@ module Run = Ligo.Run.Of_michelson let compile_file = let f source_file entry_point syntax display_format disable_typecheck michelson_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complexed = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complexed in let%bind typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c = Compile.Of_typed.compile typed in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in @@ -168,7 +170,9 @@ let print_cst = let print_ast = let f source_file syntax display_format = ( toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in ok @@ Format.asprintf "%a\n" Compile.Of_simplified.pretty_print simplified ) in @@ -180,7 +184,9 @@ let print_ast = let print_typed_ast = let f source_file syntax display_format = ( toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed,_ = Compile.Of_simplified.compile Env simplified in ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed ) @@ -193,7 +199,9 @@ let print_typed_ast = let print_mini_c = let f source_file syntax display_format = ( toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed,_ = Compile.Of_simplified.compile Env simplified in let%bind mini_c = Compile.Of_typed.compile typed in ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c @@ -207,7 +215,9 @@ let print_mini_c = let measure_contract = let f source_file entry_point syntax display_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c = Compile.Of_typed.compile typed in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in @@ -224,7 +234,9 @@ let measure_contract = let compile_parameter = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in @@ -234,7 +246,9 @@ let compile_parameter = Compile.Of_michelson.build_contract michelson_prg in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in - let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in + let%bind abstracted_param = Compile.Of_source.compile_expression v_syntax expression in + let%bind complex_param = Compile.Of_abstracted.compile_expression abstracted_param in + let%bind simplified_param = Compile.Of_complex.compile_expression complex_param in let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in @@ -255,7 +269,9 @@ let interpret = toplevel ~display_format @@ let%bind (decl_list,state,env) = match init_file with | Some init_file -> - let%bind simplified = Compile.Of_source.compile init_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile init_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let env = Ast_typed.program_environment typed_prg in @@ -263,7 +279,9 @@ let interpret = | None -> ok ([],Typer.Solver.initial_state,Ast_typed.Environment.full_empty) in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) init_file in - let%bind simplified_exp = Compile.Of_source.compile_expression v_syntax expression in + let%bind abstracted_exp = Compile.Of_source.compile_expression v_syntax expression in + let%bind complex_exp = Compile.Of_abstracted.compile_expression abstracted_exp in + let%bind simplified_exp = Compile.Of_complex.compile_expression complex_exp in let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in @@ -286,7 +304,9 @@ let interpret = let temp_ligo_interpreter = let f source_file syntax display_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed,_ = Compile.Of_simplified.compile Env simplified in let%bind res = Compile.Of_typed.some_interpret typed in ok @@ Format.asprintf "%s\n" res @@ -300,7 +320,9 @@ let temp_ligo_interpreter = let compile_storage = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in @@ -310,7 +332,9 @@ let compile_storage = Compile.Of_michelson.build_contract michelson_prg in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in - let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in + let%bind abstracted_param = Compile.Of_source.compile_expression v_syntax expression in + let%bind complex_param = Compile.Of_abstracted.compile_expression abstracted_param in + let%bind simplified_param = Compile.Of_complex.compile_expression complex_param in let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in @@ -329,7 +353,9 @@ let compile_storage = let dry_run = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in let env = Ast_typed.program_environment typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -339,7 +365,9 @@ let dry_run = Compile.Of_michelson.build_contract michelson_prg in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in - let%bind simplified = Compile.Of_source.compile_contract_input storage input v_syntax in + let%bind abstracted = Compile.Of_source.compile_contract_input storage input v_syntax in + let%bind complex = Compile.Of_abstracted.compile_expression abstracted in + let%bind simplified = Compile.Of_complex.compile_expression complex in let%bind typed,_ = Compile.Of_simplified.compile_expression ~env ~state simplified in let%bind mini_c = Compile.Of_typed.compile_expression typed in let%bind compiled_params = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c in @@ -365,13 +393,17 @@ let run_function = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in - let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex_prg = Compile.Of_abstracted.compile abstracted_prg in + let%bind simplified_prg = Compile.Of_complex.compile complex_prg in let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified_prg in let env = Ast_typed.program_environment typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in - let%bind simplified_param = Compile.Of_source.compile_expression v_syntax parameter in + let%bind abstracted_param = Compile.Of_source.compile_expression v_syntax parameter in + let%bind complex_param = Compile.Of_abstracted.compile_expression abstracted_param in + let%bind simplified_param = Compile.Of_complex.compile_expression complex_param in let%bind app = Compile.Of_simplified.apply entry_point simplified_param in let%bind (typed_app,_) = Compile.Of_simplified.compile_expression ~env ~state app in let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in @@ -396,7 +428,9 @@ let run_function = let evaluate_value = let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ - let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex = Compile.Of_abstracted.compile abstracted in + let%bind simplified = Compile.Of_complex.compile complex in let%bind typed_prg,_ = Compile.Of_simplified.compile Env simplified in let%bind mini_c = Compile.Of_typed.compile typed_prg in let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in @@ -418,7 +452,9 @@ let compile_expression = let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (None) in let env = Ast_typed.Environment.full_empty in let state = Typer.Solver.initial_state in - let%bind simplified = Compile.Of_source.compile_expression v_syntax expression in + let%bind abstracted = Compile.Of_source.compile_expression v_syntax expression in + let%bind complex = Compile.Of_abstracted.compile_expression abstracted in + let%bind simplified = Compile.Of_complex.compile_expression complex in let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified in let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in let%bind compiled_exp = Compile.Of_mini_c.compile_expression mini_c_exp in @@ -442,7 +478,9 @@ let dump_changelog = let list_declarations = let f source_file syntax = toplevel ~display_format:(`Human_readable) @@ - let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind abstracted_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind complex_prg = Compile.Of_abstracted.compile abstracted_prg in + let%bind simplified_prg = Compile.Of_complex.compile complex_prg in let json_decl = List.map (fun decl -> `String decl) @@ Compile.Of_simplified.list_declarations simplified_prg in ok @@ J.to_string @@ `Assoc [ ("source_file", `String source_file) ; ("declarations", `List json_decl) ] in diff --git a/src/main/compile/dune b/src/main/compile/dune index 98ff34494..514fa22f5 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -5,14 +5,20 @@ simple-utils tezos-utils parser - simplify - interpreter + abstracter + ast_imperative + self_ast_imperative + instruction_remover + ast_complex + self_ast_complex + simplifier ast_simplified self_ast_simplified typer_new typer ast_typed self_ast_typed + interpreter transpiler mini_c self_mini_c diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 95038a5b9..d4809c9eb 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -24,8 +24,8 @@ let parsify_pascaligo source = trace (simple_error "parsing") @@ Parser.Pascaligo.parse_file source in let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Pascaligo.simpl_program raw + trace (simple_error "abstracting") @@ + Abstracter.Pascaligo.abstr_program raw in ok simplified let parsify_expression_pascaligo source = @@ -33,8 +33,8 @@ let parsify_expression_pascaligo source = trace (simple_error "parsing expression") @@ Parser.Pascaligo.parse_expression source in let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Pascaligo.simpl_expression raw + trace (simple_error "abstracting expression") @@ + Abstracter.Pascaligo.abstr_expression raw in ok simplified let parsify_cameligo source = @@ -42,8 +42,8 @@ let parsify_cameligo source = trace (simple_error "parsing") @@ Parser.Cameligo.parse_file source in let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw + trace (simple_error "abstracting") @@ + Abstracter.Cameligo.abstr_program raw in ok simplified let parsify_expression_cameligo source = @@ -51,8 +51,8 @@ let parsify_expression_cameligo source = trace (simple_error "parsing expression") @@ Parser.Cameligo.parse_expression source in let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Cameligo.simpl_expression raw + trace (simple_error "abstracting expression") @@ + Abstracter.Cameligo.abstr_expression raw in ok simplified let parsify_reasonligo source = @@ -60,8 +60,8 @@ let parsify_reasonligo source = trace (simple_error "parsing") @@ Parser.Reasonligo.parse_file source in let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw + trace (simple_error "abstracting") @@ + Abstracter.Cameligo.abstr_program raw in ok simplified let parsify_expression_reasonligo source = @@ -69,8 +69,8 @@ let parsify_expression_reasonligo source = trace (simple_error "parsing expression") @@ Parser.Reasonligo.parse_expression source in let%bind simplified = - trace (simple_error "simplifying expression") @@ - Simplify.Cameligo.simpl_expression raw + trace (simple_error "abstracting expression") @@ + Abstracter.Cameligo.abstr_expression raw in ok simplified let parsify syntax source = @@ -80,7 +80,7 @@ let parsify syntax source = | CameLIGO -> ok parsify_cameligo | ReasonLIGO -> ok parsify_reasonligo in let%bind parsified = parsify source in - let%bind applied = Self_ast_simplified.all_program parsified + let%bind applied = Self_ast_imperative.all_program parsified in ok applied let parsify_expression syntax source = @@ -89,7 +89,7 @@ let parsify_expression syntax source = | CameLIGO -> ok parsify_expression_cameligo | ReasonLIGO -> ok parsify_expression_reasonligo in let%bind parsified = parsify source in - let%bind applied = Self_ast_simplified.all_expression parsified + let%bind applied = Self_ast_imperative.all_expression parsified in ok applied let parsify_string_reasonligo source = @@ -97,8 +97,8 @@ let parsify_string_reasonligo source = trace (simple_error "parsing") @@ Parser.Reasonligo.parse_string source in let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw + trace (simple_error "abstracting") @@ + Abstracter.Cameligo.abstr_program raw in ok simplified let parsify_string_pascaligo source = @@ -106,8 +106,8 @@ let parsify_string_pascaligo source = trace (simple_error "parsing") @@ Parser.Pascaligo.parse_string source in let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Pascaligo.simpl_program raw + trace (simple_error "abstracting") @@ + Abstracter.Pascaligo.abstr_program raw in ok simplified let parsify_string_cameligo source = @@ -115,8 +115,8 @@ let parsify_string_cameligo source = trace (simple_error "parsing") @@ Parser.Cameligo.parse_string source in let%bind simplified = - trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw + trace (simple_error "abstracting") @@ + Abstracter.Cameligo.abstr_program raw in ok simplified let parsify_string syntax source = @@ -126,7 +126,7 @@ let parsify_string syntax source = | CameLIGO -> ok parsify_string_cameligo | ReasonLIGO -> ok parsify_string_reasonligo in let%bind parsified = parsify source in - let%bind applied = Self_ast_simplified.all_program parsified + let%bind applied = Self_ast_imperative.all_program parsified in ok applied let pretty_print_pascaligo source = diff --git a/src/main/compile/of_abstracted.ml b/src/main/compile/of_abstracted.ml new file mode 100644 index 000000000..b56b1991d --- /dev/null +++ b/src/main/compile/of_abstracted.ml @@ -0,0 +1,25 @@ +open Trace +open Ast_imperative +open Instruction_remover + +type form = + | Contract of string + | Env + +let compile (program : program) : Ast_complex.program result = + remove_instruction_in_program program + +let compile_expression (e : expression) : Ast_complex.expression result = + remove_instruction_in_expression e + +let pretty_print formatter (program : program) = + PP.program formatter program + +let list_declarations (program : program) : string list = + List.fold_left + (fun prev el -> + let open Location in + match el.wrap_content with + | Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev + | _ -> prev) + [] program diff --git a/src/main/compile/of_complex.ml b/src/main/compile/of_complex.ml new file mode 100644 index 000000000..390737bbd --- /dev/null +++ b/src/main/compile/of_complex.ml @@ -0,0 +1,25 @@ +open Trace +open Ast_complex +open Simplifier + +type form = + | Contract of string + | Env + +let compile (program : program) : Ast_simplified.program result = + simplify_program program + +let compile_expression (e : expression) : Ast_simplified.expression result = + simplify_expression e + +let pretty_print formatter (program : program) = + PP.program formatter program + +let list_declarations (program : program) : string list = + List.fold_left + (fun prev el -> + let open Location in + match el.wrap_content with + | Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev + | _ -> prev) + [] program diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 433321da4..01e3a4562 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -13,9 +13,9 @@ let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.progra | Env -> ok applied in ok @@ (applied', state) -let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) +let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (e : Ast_simplified.expression) : (Ast_typed.expression * Typer.Solver.state) result = - let%bind (ae_typed,state) = Typer.type_expression_subst env state ae in + let%bind (ae_typed,state) = Typer.type_expression_subst env state e in let () = Typer.Solver.discard_state state in let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in ok @@ (ae_typed',state) diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 3a075ac9e..8b737237b 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -1,23 +1,23 @@ open Trace open Helpers -let compile (source_filename:string) syntax : Ast_simplified.program result = +let compile (source_filename:string) syntax : Ast_imperative.program result = let%bind syntax = syntax_to_variant syntax (Some source_filename) in - let%bind simplified = parsify syntax source_filename in - ok simplified + let%bind abstract = parsify syntax source_filename in + ok abstract -let compile_string (source:string) syntax : Ast_simplified.program result = - let%bind simplified = parsify_string syntax source in - ok simplified +let compile_string (source:string) syntax : Ast_imperative.program result = + let%bind abstract = parsify_string syntax source in + ok abstract -let compile_expression : v_syntax -> string -> Ast_simplified.expression result = +let compile_expression : v_syntax -> string -> Ast_imperative.expression result = fun syntax exp -> parsify_expression syntax exp -let compile_contract_input : string -> string -> v_syntax -> Ast_simplified.expression result = +let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expression result = fun storage parameter syntax -> let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in - ok @@ Ast_simplified.e_pair storage parameter + ok @@ Ast_imperative.e_pair storage parameter 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/run/dune b/src/main/run/dune index faaedeab4..ad6ef9cc5 100644 --- a/src/main/run/dune +++ b/src/main/run/dune @@ -5,7 +5,9 @@ simple-utils tezos-utils parser - simplify + abstracter + self_ast_imperative + simplifier ast_simplified typer_new typer diff --git a/src/passes/6-interpreter/dune b/src/passes/10-interpreter/dune similarity index 100% rename from src/passes/6-interpreter/dune rename to src/passes/10-interpreter/dune diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml similarity index 100% rename from src/passes/6-interpreter/interpreter.ml rename to src/passes/10-interpreter/interpreter.ml diff --git a/src/passes/6-interpreter/interpreter.mli b/src/passes/10-interpreter/interpreter.mli similarity index 100% rename from src/passes/6-interpreter/interpreter.mli rename to src/passes/10-interpreter/interpreter.mli diff --git a/src/passes/6-transpiler/dune b/src/passes/10-transpiler/dune similarity index 100% rename from src/passes/6-transpiler/dune rename to src/passes/10-transpiler/dune diff --git a/src/passes/6-transpiler/helpers.ml b/src/passes/10-transpiler/helpers.ml similarity index 100% rename from src/passes/6-transpiler/helpers.ml rename to src/passes/10-transpiler/helpers.ml diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml similarity index 100% rename from src/passes/6-transpiler/transpiler.ml rename to src/passes/10-transpiler/transpiler.ml diff --git a/src/passes/6-transpiler/transpiler.mli b/src/passes/10-transpiler/transpiler.mli similarity index 100% rename from src/passes/6-transpiler/transpiler.mli rename to src/passes/10-transpiler/transpiler.mli diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml similarity index 100% rename from src/passes/6-transpiler/untranspiler.ml rename to src/passes/10-transpiler/untranspiler.ml diff --git a/src/passes/7-self_mini_c/dune b/src/passes/11-self_mini_c/dune similarity index 100% rename from src/passes/7-self_mini_c/dune rename to src/passes/11-self_mini_c/dune diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/11-self_mini_c/helpers.ml similarity index 100% rename from src/passes/7-self_mini_c/helpers.ml rename to src/passes/11-self_mini_c/helpers.ml diff --git a/src/passes/7-self_mini_c/michelson_restrictions.ml b/src/passes/11-self_mini_c/michelson_restrictions.ml similarity index 100% rename from src/passes/7-self_mini_c/michelson_restrictions.ml rename to src/passes/11-self_mini_c/michelson_restrictions.ml diff --git a/src/passes/7-self_mini_c/self_mini_c.ml b/src/passes/11-self_mini_c/self_mini_c.ml similarity index 100% rename from src/passes/7-self_mini_c/self_mini_c.ml rename to src/passes/11-self_mini_c/self_mini_c.ml diff --git a/src/passes/7-self_mini_c/subst.ml b/src/passes/11-self_mini_c/subst.ml similarity index 100% rename from src/passes/7-self_mini_c/subst.ml rename to src/passes/11-self_mini_c/subst.ml diff --git a/src/passes/8-compiler/compiler.ml b/src/passes/12-compiler/compiler.ml similarity index 100% rename from src/passes/8-compiler/compiler.ml rename to src/passes/12-compiler/compiler.ml diff --git a/src/passes/8-compiler/compiler_environment.ml b/src/passes/12-compiler/compiler_environment.ml similarity index 100% rename from src/passes/8-compiler/compiler_environment.ml rename to src/passes/12-compiler/compiler_environment.ml diff --git a/src/passes/8-compiler/compiler_environment.mli b/src/passes/12-compiler/compiler_environment.mli similarity index 100% rename from src/passes/8-compiler/compiler_environment.mli rename to src/passes/12-compiler/compiler_environment.mli diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/12-compiler/compiler_program.ml similarity index 100% rename from src/passes/8-compiler/compiler_program.ml rename to src/passes/12-compiler/compiler_program.ml diff --git a/src/passes/8-compiler/compiler_program.mli b/src/passes/12-compiler/compiler_program.mli similarity index 100% rename from src/passes/8-compiler/compiler_program.mli rename to src/passes/12-compiler/compiler_program.mli diff --git a/src/passes/8-compiler/compiler_type.ml b/src/passes/12-compiler/compiler_type.ml similarity index 100% rename from src/passes/8-compiler/compiler_type.ml rename to src/passes/12-compiler/compiler_type.ml diff --git a/src/passes/8-compiler/compiler_type.mli b/src/passes/12-compiler/compiler_type.mli similarity index 100% rename from src/passes/8-compiler/compiler_type.mli rename to src/passes/12-compiler/compiler_type.mli diff --git a/src/passes/8-compiler/dune b/src/passes/12-compiler/dune similarity index 100% rename from src/passes/8-compiler/dune rename to src/passes/12-compiler/dune diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/12-compiler/uncompiler.ml similarity index 100% rename from src/passes/8-compiler/uncompiler.ml rename to src/passes/12-compiler/uncompiler.ml diff --git a/src/passes/8-compiler/uncompiler.mli b/src/passes/12-compiler/uncompiler.mli similarity index 100% rename from src/passes/8-compiler/uncompiler.mli rename to src/passes/12-compiler/uncompiler.mli diff --git a/src/passes/9-self_michelson/dune b/src/passes/13-self_michelson/dune similarity index 100% rename from src/passes/9-self_michelson/dune rename to src/passes/13-self_michelson/dune diff --git a/src/passes/9-self_michelson/helpers.ml b/src/passes/13-self_michelson/helpers.ml similarity index 100% rename from src/passes/9-self_michelson/helpers.ml rename to src/passes/13-self_michelson/helpers.ml diff --git a/src/passes/3-self_ast_simplified/main.ml b/src/passes/13-self_michelson/main.ml similarity index 100% rename from src/passes/3-self_ast_simplified/main.ml rename to src/passes/13-self_michelson/main.ml diff --git a/src/passes/9-self_michelson/self_michelson.ml b/src/passes/13-self_michelson/self_michelson.ml similarity index 100% rename from src/passes/9-self_michelson/self_michelson.ml rename to src/passes/13-self_michelson/self_michelson.ml diff --git a/src/passes/2-simplify/simplify.ml b/src/passes/2-abstracter/abstracter.ml similarity index 100% rename from src/passes/2-simplify/simplify.ml rename to src/passes/2-abstracter/abstracter.ml diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-abstracter/cameligo.ml similarity index 87% rename from src/passes/2-simplify/cameligo.ml rename to src/passes/2-abstracter/cameligo.ml index 4e82b9d11..9cf5891eb 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-abstracter/cameligo.ml @@ -1,7 +1,7 @@ [@@@warning "-45"] open Trace -open Ast_simplified +open Ast_imperative module Raw = Parser.Cameligo.AST module SMap = Map.String @@ -114,8 +114,8 @@ module Errors = struct ] in error ~data title message - let simplifying_expr t = - let title () = "Simplifying expression" in + let abstracting_expr t = + let title () = "abstracting expression" in let message () = "" in let data = [ ("expression" , @@ -156,7 +156,7 @@ end open Errors -open Operators.Simplify.Cameligo +open Operators.Abstracter.Cameligo let r_split = Location.r_split @@ -205,7 +205,7 @@ let rec typed_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern -> | Raw.PTyped pt -> let (p,t) = pt.value.pattern,pt.value.type_expr in let%bind p = tuple_pattern_to_vars p in - let%bind t = simpl_type_expression t in + let%bind t = abstr_type_expression t in ok @@ (p,t) | other -> (fail @@ wrong_pattern "parenthetical or type annotation" other) @@ -213,10 +213,10 @@ and unpar_pattern : Raw.pattern -> Raw.pattern = function | PPar p -> unpar_pattern p.value.inside | _ as p -> p -and simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> - trace (simple_info "simplifying this type expression...") @@ +and abstr_type_expression : Raw.type_expr -> type_expression result = fun te -> + trace (simple_info "abstracting this type expression...") @@ match te with - TPar x -> simpl_type_expression x.value.inside + TPar x -> abstr_type_expression x.value.inside | TVar v -> ( match type_constants v.value with | Ok (s,_) -> ok @@ make_t @@ T_constant s @@ -225,8 +225,8 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> | TFun x -> ( let%bind (type1 , type2) = let (a , _ , b) = x.value in - let%bind a = simpl_type_expression a in - let%bind b = simpl_type_expression b in + let%bind a = abstr_type_expression a in + let%bind b = abstr_type_expression b in ok (a , b) in ok @@ make_t @@ T_arrow {type1;type2} @@ -234,18 +234,18 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> | TApp x -> ( let (name, tuple) = x.value in let lst = npseq_to_list tuple.value.inside in - let%bind lst' = bind_map_list simpl_type_expression lst in + let%bind lst' = bind_map_list abstr_type_expression lst in let%bind cst = trace (unknown_predefined_type name) @@ type_operators name.value in t_operator cst lst' ) | TProd p -> ( - let%bind tpl = simpl_list_type_expression @@ npseq_to_list p.value in + let%bind tpl = abstr_list_type_expression @@ npseq_to_list p.value in ok tpl ) | TRecord r -> - let aux = fun (x, y) -> let%bind y = simpl_type_expression y in ok (x, y) in + let aux = fun (x, y) -> let%bind y = abstr_type_expression y in ok (x, y) in let apply (x:Raw.field_decl Raw.reg) = (x.value.field_name.value, x.value.field_type) in let%bind lst = @@ -262,7 +262,7 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> None -> [] | Some (_, TProd product) -> npseq_to_list product.value | Some (_, t_expr) -> [t_expr] in - let%bind te = simpl_list_type_expression @@ args in + let%bind te = abstr_list_type_expression @@ args in ok (v.value.constr.value, te) in let%bind lst = bind_list @@ List.map aux @@ -270,18 +270,18 @@ and simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in ok @@ make_t @@ T_sum m -and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result = +and abstr_list_type_expression (lst:Raw.type_expr list) : type_expression result = match lst with | [] -> ok @@ t_unit - | [hd] -> simpl_type_expression hd + | [hd] -> abstr_type_expression hd | lst -> - let%bind lst = bind_map_list simpl_type_expression lst in + let%bind lst = bind_map_list abstr_type_expression lst in ok @@ t_tuple lst -let rec simpl_expression : +let rec abstr_expression : Raw.expr -> expr result = fun t -> let return x = ok x in - let simpl_projection = fun (p:Raw.projection Region.reg) -> + let abstr_projection = fun (p:Raw.projection Region.reg) -> let (p , loc) = r_split p in let var = let name = Var.of_name p.struct_name.value in @@ -296,7 +296,7 @@ let rec simpl_expression : List.map aux @@ npseq_to_list path in return @@ List.fold_left (e_accessor ~loc ) var path' in - let simpl_path : Raw.path -> string * label list = fun p -> + let abstr_path : Raw.path -> string * label list = fun p -> match p with | Raw.Name v -> (v.value , []) | Raw.Path p -> ( @@ -313,9 +313,9 @@ let rec simpl_expression : (var , path') ) in - let simpl_update = fun (u:Raw.update Region.reg) -> + let abstr_update = fun (u:Raw.update Region.reg) -> let (u, loc) = r_split u in - let (name, path) = simpl_path u.record in + let (name, path) = abstr_path u.record in let record = match path with | [] -> e_variable (Var.of_name name) | _ -> @@ -325,7 +325,7 @@ let rec simpl_expression : let%bind updates' = let aux (f:Raw.field_path_assign Raw.reg) = let (f,_) = r_split f in - let%bind expr = simpl_expression f.field_expr in + let%bind expr = abstr_expression f.field_expr in ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) in bind_map_list aux @@ npseq_to_list updates @@ -342,7 +342,7 @@ let rec simpl_expression : bind_fold_list aux record updates' in - trace (simplifying_expr t) @@ + trace (abstracting_expr t) @@ match t with Raw.ELetIn e -> let Raw.{kwd_rec; binding; body; attributes; _} = e.value in @@ -352,20 +352,20 @@ let rec simpl_expression : | (p, []) -> let%bind variables = tuple_pattern_to_typed_vars p in let%bind ty_opt = - bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in - let%bind rhs = simpl_expression let_rhs in + bind_map_option (fun (_,te) -> abstr_type_expression te) lhs_type in + let%bind rhs = abstr_expression let_rhs in let rhs_b = Var.fresh ~name: "rhs" () in let rhs',rhs_b_expr = match ty_opt with None -> rhs, e_variable rhs_b | Some ty -> (e_annotation rhs ty), e_annotation (e_variable rhs_b) ty in - let%bind body = simpl_expression body in + let%bind body = abstr_expression body in let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = let variable, ty_opt = ty_var in let var_expr = Var.of_name variable.value in let%bind ty_expr_opt = match ty_opt with - | Some ty -> bind_map_option simpl_type_expression (Some ty) + | Some ty -> bind_map_option abstr_type_expression (Some ty) | None -> ok None in ok (var_expr, ty_expr_opt) in @@ -397,7 +397,7 @@ let rec simpl_expression : | None -> (match let_rhs with | EFun {value={binders;lhs_type}} -> let f_args = nseq_to_list (binders) in - let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in + let%bind lhs_type' = bind_map_option (fun x -> abstr_type_expression (snd x)) lhs_type in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in let aux acc ty = Option.map (t_function (snd ty)) acc in ok @@ (List.fold_right' aux lhs_type' ty) @@ -444,8 +444,8 @@ let rec simpl_expression : end | Raw.EAnnot a -> let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in - let%bind expr' = simpl_expression expr in - let%bind type_expr' = simpl_type_expression type_expr in + let%bind expr' = abstr_expression expr in + let%bind type_expr' = abstr_type_expression type_expr in return @@ e_annotation ~loc expr' type_expr' | EVar c -> let (c',loc) = r_split c in @@ -454,7 +454,7 @@ let rec simpl_expression : | Ok (s,_) -> return @@ e_constant s []) | ECall x -> ( let ((e1 , e2) , loc) = r_split x in - let%bind args = bind_map_list simpl_expression (nseq_to_list e2) in + let%bind args = bind_map_list abstr_expression (nseq_to_list e2) in let rec chain_application (f: expression) (args: expression list) = match args with | hd :: tl -> chain_application (e_application ~loc f hd) tl @@ -468,29 +468,29 @@ let rec simpl_expression : | Ok (s, _) -> return @@ e_constant ~loc s args ) | e1 -> - let%bind e1' = simpl_expression e1 in + let%bind e1' = abstr_expression e1 in return @@ chain_application e1' args ) - | EPar x -> simpl_expression x.value.inside + | EPar x -> abstr_expression x.value.inside | EUnit reg -> let (_ , loc) = r_split reg in return @@ e_literal ~loc Literal_unit | EBytes x -> let (x , loc) = r_split x in return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x)) - | ETuple tpl -> simpl_tuple_expression @@ (npseq_to_list tpl.value) + | ETuple tpl -> abstr_tuple_expression @@ (npseq_to_list tpl.value) | ERecord r -> let (r , loc) = r_split r in let%bind fields = bind_list - @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) + @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = abstr_expression v in ok (k.value, v)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ npseq_to_list r.ne_elements in return @@ e_record_ez ~loc fields - | EProj p -> simpl_projection p - | EUpdate u -> simpl_update u + | EProj p -> abstr_projection p + | EUpdate u -> abstr_update u | EConstr (ESomeApp a) -> let (_, args), loc = r_split a in - let%bind arg = simpl_expression args in + let%bind arg = abstr_expression args in return @@ e_constant ~loc C_SOME [arg] | EConstr (ENone reg) -> let loc = Location.lift reg in @@ -502,18 +502,18 @@ let rec simpl_expression : match args with None -> [] | Some arg -> [arg] in - let%bind arg = simpl_tuple_expression @@ args + let%bind arg = abstr_tuple_expression @@ args in return @@ e_constructor ~loc c_name arg | EArith (Add c) -> - simpl_binop "ADD" c + abstr_binop "ADD" c | EArith (Sub c) -> - simpl_binop "SUB" c + abstr_binop "SUB" c | EArith (Mult c) -> - simpl_binop "TIMES" c + abstr_binop "TIMES" c | EArith (Div c) -> - simpl_binop "DIV" c + abstr_binop "DIV" c | EArith (Mod c) -> - simpl_binop "MOD" c + abstr_binop "MOD" c | EArith (Int n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in @@ -529,7 +529,7 @@ let rec simpl_expression : let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_mutez n) ) - | EArith (Neg e) -> simpl_unop "NEG" e + | EArith (Neg e) -> abstr_unop "NEG" e | EString (String s) -> ( let (s , loc) = r_split s in let s' = @@ -540,24 +540,24 @@ let rec simpl_expression : ) | EString (Cat c) -> let (c, loc) = r_split c in - let%bind string_left = simpl_expression c.arg1 in - let%bind string_right = simpl_expression c.arg2 in + let%bind string_left = abstr_expression c.arg1 in + let%bind string_right = abstr_expression c.arg2 in return @@ e_string_cat ~loc string_left string_right - | ELogic l -> simpl_logic_expression l - | EList l -> simpl_list_expression l + | ELogic l -> abstr_logic_expression l + | EList l -> abstr_list_expression l | ECase c -> ( let (c , loc) = r_split c in - let%bind e = simpl_expression c.expr in + let%bind e = abstr_expression c.expr in let%bind lst = let aux (x : Raw.expr Raw.case_clause) = - let%bind expr = simpl_expression x.rhs in + let%bind expr = abstr_expression x.rhs in ok (x.pattern, expr) in bind_list @@ List.map aux @@ List.map get_value @@ npseq_to_list c.cases.value in let default_action () = - let%bind cases = simpl_cases lst in + let%bind cases = abstr_cases lst in return @@ e_matching ~loc e cases in (* Hack to take care of patterns introduced by `parser/cameligo/Parser.mly` in "norm_fun_expr". TODO: Still needed? *) match lst with @@ -571,7 +571,7 @@ let rec simpl_expression : match x'.pattern with | Raw.PVar y -> let var_name = Var.of_name y.value in - let%bind type_expr = simpl_type_expression x'.type_expr in + let%bind type_expr = abstr_type_expression x'.type_expr in return @@ e_let_in (var_name , Some type_expr) false false e rhs | _ -> default_action () ) @@ -581,29 +581,29 @@ let rec simpl_expression : ) | _ -> default_action () ) - | EFun lamb -> simpl_fun lamb + | EFun lamb -> abstr_fun lamb | ESeq s -> ( let (s , loc) = r_split s in let items : Raw.expr list = pseq_to_list s.elements in (match items with [] -> return @@ e_skip ~loc () | expr::more -> - let expr' = simpl_expression expr in + let expr' = abstr_expression expr in let apply (e1: Raw.expr) (e2: expression Trace.result) = - let%bind a = simpl_expression e1 in + let%bind a = abstr_expression e1 in let%bind e2' = e2 in return @@ e_sequence a e2' in List.fold_right apply more expr') ) | ECond c -> ( let (c , loc) = r_split c in - let%bind expr = simpl_expression c.test in - let%bind match_true = simpl_expression c.ifso in - let%bind match_false = simpl_expression c.ifnot in + let%bind expr = abstr_expression c.test in + let%bind match_true = abstr_expression c.ifso in + let%bind match_false = abstr_expression c.ifnot in return @@ e_matching ~loc expr (Match_bool {match_true; match_false}) ) -and simpl_fun lamb' : expr result = +and abstr_fun lamb' : expr result = let return x = ok x in let (lamb , loc) = r_split lamb' in let%bind params' = @@ -649,7 +649,7 @@ and simpl_fun lamb' : expr result = | _ , None -> fail @@ untyped_fun_param var | _ , Some ty -> ( - let%bind ty' = simpl_type_expression ty in + let%bind ty' = abstr_type_expression ty in ok (var , ty') ) in @@ -700,8 +700,8 @@ and simpl_fun lamb' : expr result = in let%bind (body , body_type) = expr_to_typed_expr body in let%bind output_type = - bind_map_option simpl_type_expression body_type in - let%bind body = simpl_expression body in + bind_map_option abstr_type_expression body_type in + let%bind body = abstr_expression body in let rec layer_arguments (arguments: (Raw.variable * type_expression) list) = match arguments with | hd :: tl -> @@ -714,7 +714,7 @@ and simpl_fun lamb' : expr result = return @@ ret_lamb -and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = +and abstr_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = let return x = ok @@ make_option_typed x te_annot in match t with | BoolExpr (False reg) -> ( @@ -726,61 +726,61 @@ and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = return @@ e_literal ~loc (Literal_bool true) ) | BoolExpr (Or b) -> - simpl_binop "OR" b + abstr_binop "OR" b | BoolExpr (And b) -> - simpl_binop "AND" b + abstr_binop "AND" b | BoolExpr (Not b) -> - simpl_unop "NOT" b + abstr_unop "NOT" b | CompExpr (Lt c) -> - simpl_binop "LT" c + abstr_binop "LT" c | CompExpr (Gt c) -> - simpl_binop "GT" c + abstr_binop "GT" c | CompExpr (Leq c) -> - simpl_binop "LE" c + abstr_binop "LE" c | CompExpr (Geq c) -> - simpl_binop "GE" c + abstr_binop "GE" c | CompExpr (Equal c) -> - simpl_binop "EQ" c + abstr_binop "EQ" c | CompExpr (Neq c) -> - simpl_binop "NEQ" c + abstr_binop "NEQ" c -and simpl_list_expression (t:Raw.list_expr) : expression result = +and abstr_list_expression (t:Raw.list_expr) : expression result = let return x = ok @@ x in match t with - ECons c -> simpl_binop "CONS" c + ECons c -> abstr_binop "CONS" c | EListComp lst -> ( let (lst , loc) = r_split lst in let%bind lst' = - bind_map_list simpl_expression @@ + bind_map_list abstr_expression @@ pseq_to_list lst.elements in return @@ e_list ~loc lst' ) -and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = +and abstr_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = let return x = ok @@ x in let (args , loc) = r_split t in - let%bind a = simpl_expression args.arg1 in - let%bind b = simpl_expression args.arg2 in + let%bind a = abstr_expression args.arg1 in + let%bind b = abstr_expression args.arg2 in let%bind name = constants name in return @@ e_constant ~loc name [ a ; b ] -and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = +and abstr_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = let return x = ok @@ x in let (t , loc) = r_split t in - let%bind a = simpl_expression t.arg in + let%bind a = abstr_expression t.arg in let%bind name = constants name in return @@ e_constant ~loc name [ a ] -and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = +and abstr_tuple_expression ?loc (lst:Raw.expr list) : expression result = let return x = ok @@ x in match lst with | [] -> return @@ e_literal ?loc Literal_unit - | [hd] -> simpl_expression hd + | [hd] -> abstr_expression hd | lst -> - let%bind lst = bind_list @@ List.map simpl_expression lst in + let%bind lst = bind_list @@ List.map abstr_expression lst in return @@ e_tuple ?loc lst -and simpl_declaration : Raw.declaration -> declaration Location.wrap list result = +and abstr_declaration : Raw.declaration -> declaration Location.wrap list result = fun t -> let open! Raw in let loc : 'a . 'a Raw.reg -> _ -> _ = @@ -788,7 +788,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result match t with | TypeDecl x -> let {name;type_expr} : Raw.type_decl = x.value in - let%bind type_expression = simpl_type_expression type_expr in + let%bind type_expression = abstr_type_expression type_expr in ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)] | Let x -> ( let (_, recursive, let_binding, attributes), _ = r_split x in @@ -798,17 +798,16 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let (hd, _) = binders in match hd with | PTuple pt -> - let process_variable (var_pair: pattern * Raw.expr) : - Ast_simplified.declaration Location.wrap result = + let process_variable (var_pair: pattern * Raw.expr) = (let (par_var, rhs_expr) = var_pair in let%bind (v, v_type) = pattern_to_typed_var par_var in let%bind v_type_expression = match v_type with - | Some v_type -> ok (to_option (simpl_type_expression v_type)) + | Some v_type -> ok (to_option (abstr_type_expression v_type)) | None -> ok None in - let%bind simpl_rhs_expr = simpl_expression rhs_expr in - ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, simpl_rhs_expr) ) + let%bind abstr_rhs_expr = abstr_expression rhs_expr in + ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, abstr_rhs_expr) ) in let%bind variables = ok @@ npseq_to_list pt.value in let%bind expr_bind_lst = match let_rhs with @@ -840,7 +839,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result gen_access_tuple name ~i: (i + 1) ~accesses in ok (gen_access_tuple name) (* TODO: Improve this error message *) - | other -> fail @@ simplifying_expr other + | other -> fail @@ abstracting_expr other in let%bind decls = (* TODO: Rewrite the gen_access_tuple so there's no List.rev *) bind_map_list process_variable (List.combine variables (List.rev expr_bind_lst)) @@ -848,7 +847,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result | PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } -> (* Extract parenthetical multi-bind *) let (wild, recursive, _, attributes) = fst @@ r_split x in - simpl_declaration + abstr_declaration (Let { region = x.region; value = (wild, recursive, {binders = (pt, []); @@ -863,7 +862,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let%bind var = pattern_to_var hd in ok (var , tl) in - let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in + let%bind lhs_type' = bind_map_option (fun x -> abstr_type_expression (snd x)) lhs_type in let%bind let_rhs,lhs_type = match args with | [] -> ok (let_rhs, lhs_type') | param1::others -> @@ -879,12 +878,12 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let aux acc ty = Option.map (t_function (snd ty)) acc in ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty) in - let%bind rhs' = simpl_expression let_rhs in + let%bind rhs' = abstr_expression let_rhs in let%bind lhs_type = match lhs_type with | None -> (match let_rhs with | EFun {value={binders;lhs_type}} -> let f_args = nseq_to_list (binders) in - let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in + let%bind lhs_type' = bind_map_option (fun x -> abstr_type_expression (snd x)) lhs_type in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in let aux acc ty = Option.map (t_function (snd ty)) acc in ok @@ (List.fold_right' aux lhs_type' ty) @@ -907,7 +906,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))] ) -and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result = +and abstr_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result = fun t -> let open Raw in let rec get_var (t:Raw.pattern) = @@ -1027,6 +1026,6 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content | _ -> simple_fail "bad option pattern" in bind_or (as_option () , as_variant ()) -let simpl_program : Raw.ast -> program result = fun t -> - let%bind decls = bind_map_list simpl_declaration @@ nseq_to_list t.decl in +let abstr_program : Raw.ast -> program result = fun t -> + let%bind decls = bind_map_list abstr_declaration @@ nseq_to_list t.decl in ok @@ List.concat @@ decls diff --git a/src/passes/2-simplify/cameligo.mli b/src/passes/2-abstracter/cameligo.mli similarity index 68% rename from src/passes/2-simplify/cameligo.mli rename to src/passes/2-abstracter/cameligo.mli index a69583d73..f2e56b348 100644 --- a/src/passes/2-simplify/cameligo.mli +++ b/src/passes/2-abstracter/cameligo.mli @@ -1,8 +1,7 @@ [@@@warning "-45"] open Trace - -open Ast_simplified +open Ast_imperative module Raw = Parser.Cameligo.AST module SMap = Map.String @@ -29,7 +28,7 @@ module Errors : sig val unsupported_tuple_pattern : Raw.pattern -> unit -> error val unsupported_cst_constr : Raw.pattern -> unit -> error val unsupported_non_var_pattern : Raw.pattern -> unit -> error - val simplifying_expr : Raw.expr -> unit -> error + val abstracting_expr : Raw.expr -> unit -> error val only_constructors : Raw.pattern -> unit -> error val unsupported_sugared_lists : Raw.wild -> unit -> error val bad_set_definition : unit -> error @@ -46,18 +45,18 @@ val pattern_to_var : Raw.pattern -> Raw.variable result val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result val patterns_to_var : Raw.pattern list -> Raw.variable result -val simpl_type_expression : Raw.type_expr -> type_expression result -val simpl_list_type_expression : Raw.type_expr list -> type_expression result +val abstr_type_expression : Raw.type_expr -> type_expression result +val abstr_list_type_expression : Raw.type_expr list -> type_expression result *) -val simpl_expression : Raw.expr -> expr result +val abstr_expression : Raw.expr -> expr result (* -val simpl_fun : Raw.fun_expr Raw.reg -> expr result -val simpl_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result -val simpl_list_expression : Raw.list_expr -> expression result -val simpl_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result -val simpl_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result -val simpl_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result -val simpl_declaration : Raw.declaration -> declaration Location.wrap result -val simpl_cases : (Raw.pattern * 'a) list -> 'a matching result +val abstr_fun : Raw.fun_expr Raw.reg -> expr result +val abstr_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result +val abstr_list_expression : Raw.list_expr -> expression result +val abstr_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result +val abstr_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result +val abstr_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result +val abstr_declaration : Raw.declaration -> declaration Location.wrap result +val abstr_cases : (Raw.pattern * 'a) list -> 'a matching result *) -val simpl_program : Raw.ast -> program result +val abstr_program : Raw.ast -> program result diff --git a/src/passes/2-simplify/camligo.ml.old b/src/passes/2-abstracter/camligo.ml.old similarity index 99% rename from src/passes/2-simplify/camligo.ml.old rename to src/passes/2-abstracter/camligo.ml.old index 64c0ebd10..deb987624 100644 --- a/src/passes/2-simplify/camligo.ml.old +++ b/src/passes/2-abstracter/camligo.ml.old @@ -252,7 +252,7 @@ and expression_main : I.expression_main Location.wrap -> O.expression result = f let%bind (a' , b') = bind_map_pair expression_main ab in return @@ e_binop name a' b' in let error_main = - let title () = "simplifying main_expression" in + let title () = "abstracting main_expression" in let content () = Format.asprintf "%a" I.pp_expression_main (unwrap em) in error title content in diff --git a/src/passes/2-simplify/dune b/src/passes/2-abstracter/dune similarity index 62% rename from src/passes/2-simplify/dune rename to src/passes/2-abstracter/dune index 8e506cebc..a18e1a3cd 100644 --- a/src/passes/2-simplify/dune +++ b/src/passes/2-abstracter/dune @@ -1,14 +1,14 @@ (library - (name simplify) - (public_name ligo.simplify) + (name abstracter) + (public_name ligo.abstracter) (libraries simple-utils tezos-utils parser - ast_simplified - self_ast_simplified + ast_imperative + self_ast_imperative operators) - (modules cameligo pascaligo simplify) + (modules cameligo pascaligo abstracter) (preprocess (pps ppx_let diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-abstracter/pascaligo.ml similarity index 83% rename from src/passes/2-simplify/pascaligo.ml rename to src/passes/2-abstracter/pascaligo.ml index a0c051f28..d36a4532d 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-abstracter/pascaligo.ml @@ -1,5 +1,5 @@ open Trace -open Ast_simplified +open Ast_imperative module Raw = Parser.Pascaligo.AST module SMap = Map.String @@ -15,7 +15,7 @@ let pseq_to_list = function let get_value : 'a Raw.reg -> 'a = fun x -> x.value and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = - let%bind captured_names = Self_ast_simplified.fold_map_expression + let%bind captured_names = Self_ast_imperative.fold_map_expression (* TODO : these should use Variables sets *) (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> match ass_exp.expression_content with @@ -47,7 +47,7 @@ and repair_mutable_variable_in_matching (for_body : expression) (element_names : ok @@ captured_names and repair_mutable_variable_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = - let%bind captured_names = Self_ast_simplified.fold_map_expression + let%bind captured_names = Self_ast_imperative.fold_map_expression (* TODO : these should use Variables sets *) (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> match ass_exp.expression_content with @@ -186,7 +186,7 @@ module Errors = struct (* Logging *) - let simplifying_instruction t = + let abstracting_instruction t = let title () = "\nSimplifiying instruction" in let message () = "" in (** TODO: The labelled arguments should be flowing from the CLI. *) @@ -199,14 +199,14 @@ module Errors = struct end open Errors -open Operators.Simplify.Pascaligo +open Operators.Abstracter.Pascaligo let r_split = Location.r_split (* Statements can't be simplified in isolation. [a ; b ; c] can get simplified either as [let x = expr in (b ; c)] if [a] is a [const x = expr] declaration or as [sequence(a, sequence(b, c))] for - everything else. Because of this, simplifying sequences depend on + everything else. Because of this, abstracting sequences depend on their contents. To avoid peeking in their contents, we instead simplify sequences elements as functions from their next elements to the actual result. @@ -229,9 +229,9 @@ let return_statement expr = ok @@ fun expr'_opt -> | Some expr' -> ok @@ e_sequence expr expr' -let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = +let rec abstr_type_expression (t:Raw.type_expr) : type_expression result = match t with - TPar x -> simpl_type_expression x.value.inside + TPar x -> abstr_type_expression x.value.inside | TVar v -> ( match type_constants v.value with | Ok (s,_) -> ok @@ make_t @@ T_constant s @@ -240,25 +240,25 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = | TFun x -> ( let%bind (a , b) = let (a , _ , b) = x.value in - bind_map_pair simpl_type_expression (a , b) in + bind_map_pair abstr_type_expression (a , b) in ok @@ make_t @@ T_arrow {type1=a;type2=b} ) | TApp x -> let (name, tuple) = x.value in let lst = npseq_to_list tuple.value.inside in let%bind lst = - bind_list @@ List.map simpl_type_expression lst in (** TODO: fix constant and operator*) + bind_list @@ List.map abstr_type_expression lst in (** TODO: fix constant and operator*) let%bind cst = trace (unknown_predefined_type name) @@ type_operators name.value in t_operator cst lst | TProd p -> - let%bind tpl = simpl_list_type_expression + let%bind tpl = abstr_list_type_expression @@ npseq_to_list p.value in ok tpl | TRecord r -> let aux = fun (x, y) -> - let%bind y = simpl_type_expression y in + let%bind y = abstr_type_expression y in ok (x, y) in let apply = @@ -276,7 +276,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = None -> [] | Some (_, TProd product) -> npseq_to_list product.value | Some (_, t_expr) -> [t_expr] in - let%bind te = simpl_list_type_expression @@ args in + let%bind te = abstr_list_type_expression @@ args in ok (v.value.constr.value, te) in let%bind lst = bind_list @@ -285,15 +285,15 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in ok @@ make_t @@ T_sum m -and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result = +and abstr_list_type_expression (lst:Raw.type_expr list) : type_expression result = match lst with | [] -> ok @@ t_unit - | [hd] -> simpl_type_expression hd + | [hd] -> abstr_type_expression hd | lst -> - let%bind lst = bind_list @@ List.map simpl_type_expression lst in + let%bind lst = bind_list @@ List.map abstr_type_expression lst in ok @@ t_tuple lst -let simpl_projection : Raw.projection Region.reg -> _ = fun p -> +let abstr_projection : Raw.projection Region.reg -> _ = fun p -> let (p' , loc) = r_split p in let var = let name = Var.of_name p'.struct_name.value in @@ -309,13 +309,13 @@ let simpl_projection : Raw.projection Region.reg -> _ = fun p -> ok @@ List.fold_left (e_accessor ~loc) var path' -let rec simpl_expression (t:Raw.expr) : expr result = +let rec abstr_expression (t:Raw.expr) : expr result = let return x = ok x in match t with | EAnnot a -> ( let ((expr , type_expr) , loc) = r_split a in - let%bind expr' = simpl_expression expr in - let%bind type_expr' = simpl_type_expression type_expr in + let%bind expr' = abstr_expression expr in + let%bind type_expr' = abstr_type_expression type_expr in return @@ e_annotation ~loc expr' type_expr' ) | EVar c -> ( @@ -333,19 +333,19 @@ let rec simpl_expression (t:Raw.expr) : expr result = let (f_name , f_loc) = r_split name in match constants f_name with | Error _ -> - let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + let%bind arg = abstr_tuple_expression ~loc:args_loc args' in return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg | Ok (s,_) -> - let%bind lst = bind_map_list simpl_expression args' in + let%bind lst = bind_map_list abstr_expression args' in return @@ e_constant ~loc s lst ) | f -> ( - let%bind f' = simpl_expression f in - let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + let%bind f' = abstr_expression f in + let%bind arg = abstr_tuple_expression ~loc:args_loc args' in return @@ e_application ~loc f' arg ) ) - | EPar x -> simpl_expression x.value.inside + | EPar x -> abstr_expression x.value.inside | EUnit reg -> let loc = Location.lift reg in return @@ e_literal ~loc Literal_unit @@ -354,16 +354,16 @@ let rec simpl_expression (t:Raw.expr) : expr result = return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x')) | ETuple tpl -> let (tpl' , loc) = r_split tpl in - simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside + abstr_tuple_expression ~loc @@ npseq_to_list tpl'.inside | ERecord r -> let%bind fields = bind_list - @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) + @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = abstr_expression v in ok (k.value, v)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ npseq_to_list r.value.ne_elements in let aux prev (k, v) = SMap.add k v prev in return @@ e_record (List.fold_left aux SMap.empty fields) - | EProj p -> simpl_projection p - | EUpdate u -> simpl_update u + | EProj p -> abstr_projection p + | EUpdate u -> abstr_update u | EConstr (ConstrApp c) -> ( let ((c, args) , loc) = r_split c in match args with @@ -372,7 +372,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = | Some args -> let args, args_loc = r_split args in let%bind arg = - simpl_tuple_expression ~loc:args_loc + abstr_tuple_expression ~loc:args_loc @@ npseq_to_list args.inside in return @@ e_constructor ~loc c.value arg ) @@ -380,7 +380,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let ((_, args) , loc) = r_split a in let (args , args_loc) = r_split args in let%bind arg = - simpl_tuple_expression ~loc:args_loc + abstr_tuple_expression ~loc:args_loc @@ npseq_to_list args.inside in return @@ e_constant ~loc C_SOME [arg] | EConstr (NoneExpr reg) -> ( @@ -388,15 +388,15 @@ let rec simpl_expression (t:Raw.expr) : expr result = return @@ e_none ~loc () ) | EArith (Add c) -> - simpl_binop "ADD" c + abstr_binop "ADD" c | EArith (Sub c) -> - simpl_binop "SUB" c + abstr_binop "SUB" c | EArith (Mult c) -> - simpl_binop "TIMES" c + abstr_binop "TIMES" c | EArith (Div c) -> - simpl_binop "DIV" c + abstr_binop "DIV" c | EArith (Mod c) -> - simpl_binop "MOD" c + abstr_binop "MOD" c | EArith (Int n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd n in @@ -412,7 +412,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_mutez n) ) - | EArith (Neg e) -> simpl_unop "NEG" e + | EArith (Neg e) -> abstr_unop "NEG" e | EString (String s) -> let (s , loc) = r_split s in let s' = @@ -422,17 +422,17 @@ let rec simpl_expression (t:Raw.expr) : expr result = return @@ e_literal ~loc (Literal_string s') | EString (Cat bo) -> let (bo , loc) = r_split bo in - let%bind sl = simpl_expression bo.arg1 in - let%bind sr = simpl_expression bo.arg2 in + let%bind sl = abstr_expression bo.arg1 in + let%bind sr = abstr_expression bo.arg2 in return @@ e_string_cat ~loc sl sr - | ELogic l -> simpl_logic_expression l - | EList l -> simpl_list_expression l - | ESet s -> simpl_set_expression s + | ELogic l -> abstr_logic_expression l + | EList l -> abstr_list_expression l + | ESet s -> abstr_set_expression s | ECond c -> let (c , loc) = r_split c in - let%bind expr = simpl_expression c.test in - let%bind match_true = simpl_expression c.ifso in - let%bind match_false = simpl_expression c.ifnot in + let%bind expr = abstr_expression c.test in + let%bind match_true = abstr_expression c.ifso in + let%bind match_false = abstr_expression c.ifnot in let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in let env = Var.fresh () in let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in @@ -440,16 +440,16 @@ let rec simpl_expression (t:Raw.expr) : expr result = | ECase c -> ( let (c , loc) = r_split c in - let%bind e = simpl_expression c.expr in + let%bind e = abstr_expression c.expr in let%bind lst = let aux (x : Raw.expr Raw.case_clause) = - let%bind expr = simpl_expression x.rhs in + let%bind expr = abstr_expression x.rhs in ok (x.pattern, expr) in bind_list @@ List.map aux @@ List.map get_value @@ npseq_to_list c.cases.value in - let%bind cases = simpl_cases lst in + let%bind cases = abstr_cases lst in let match_expr = e_matching ~loc e cases in let env = Var.fresh () in let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in @@ -461,8 +461,8 @@ let rec simpl_expression (t:Raw.expr) : expr result = let lst = List.map get_value @@ pseq_to_list mi.elements in let aux : Raw.binding -> (expression * expression) result = fun b -> - let%bind src = simpl_expression b.source in - let%bind dst = simpl_expression b.image in + let%bind src = abstr_expression b.source in + let%bind dst = abstr_expression b.image in ok (src, dst) in bind_map_list aux lst in return @@ e_map ~loc lst @@ -473,8 +473,8 @@ let rec simpl_expression (t:Raw.expr) : expr result = let lst = List.map get_value @@ pseq_to_list mi.elements in let aux : Raw.binding -> (expression * expression) result = fun b -> - let%bind src = simpl_expression b.source in - let%bind dst = simpl_expression b.image in + let%bind src = abstr_expression b.source in + let%bind dst = abstr_expression b.image in ok (src, dst) in bind_map_list aux lst in return @@ e_big_map ~loc lst @@ -486,20 +486,20 @@ let rec simpl_expression (t:Raw.expr) : expr result = let (v , loc) = r_split v in return @@ e_variable ~loc (Var.of_name v) ) - | Path p -> simpl_projection p + | Path p -> abstr_projection p in - let%bind index = simpl_expression lu.index.value.inside in + let%bind index = abstr_expression lu.index.value.inside in return @@ e_look_up ~loc path index ) | EFun f -> let (f , loc) = r_split f in - let%bind (_ty_opt, f') = simpl_fun_expression ~loc f + let%bind (_ty_opt, f') = abstr_fun_expression ~loc f in return @@ f' -and simpl_update = fun (u:Raw.update Region.reg) -> +and abstr_update = fun (u:Raw.update Region.reg) -> let (u, loc) = r_split u in - let (name, path) = simpl_path u.record in + let (name, path) = abstr_path u.record in let record = match path with | [] -> e_variable (Var.of_name name) | _ -> e_accessor_list (e_variable (Var.of_name name)) path in @@ -507,7 +507,7 @@ and simpl_update = fun (u:Raw.update Region.reg) -> let%bind updates' = let aux (f:Raw.field_path_assign Raw.reg) = let (f,_) = r_split f in - let%bind expr = simpl_expression f.field_expr in + let%bind expr = abstr_expression f.field_expr in ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) in bind_map_list aux @@ npseq_to_list updates @@ -523,7 +523,7 @@ and simpl_update = fun (u:Raw.update Region.reg) -> aux ur path in bind_fold_list aux record updates' -and simpl_logic_expression (t:Raw.logic_expr) : expression result = +and abstr_logic_expression (t:Raw.logic_expr) : expression result = let return x = ok x in match t with | BoolExpr (False reg) -> ( @@ -535,92 +535,92 @@ and simpl_logic_expression (t:Raw.logic_expr) : expression result = return @@ e_literal ~loc (Literal_bool true) ) | BoolExpr (Or b) -> - simpl_binop "OR" b + abstr_binop "OR" b | BoolExpr (And b) -> - simpl_binop "AND" b + abstr_binop "AND" b | BoolExpr (Not b) -> - simpl_unop "NOT" b + abstr_unop "NOT" b | CompExpr (Lt c) -> - simpl_binop "LT" c + abstr_binop "LT" c | CompExpr (Gt c) -> - simpl_binop "GT" c + abstr_binop "GT" c | CompExpr (Leq c) -> - simpl_binop "LE" c + abstr_binop "LE" c | CompExpr (Geq c) -> - simpl_binop "GE" c + abstr_binop "GE" c | CompExpr (Equal c) -> - simpl_binop "EQ" c + abstr_binop "EQ" c | CompExpr (Neq c) -> - simpl_binop "NEQ" c + abstr_binop "NEQ" c -and simpl_list_expression (t:Raw.list_expr) : expression result = +and abstr_list_expression (t:Raw.list_expr) : expression result = let return x = ok x in match t with ECons c -> - simpl_binop "CONS" c + abstr_binop "CONS" c | EListComp lst -> let (lst , loc) = r_split lst in let%bind lst' = - bind_map_list simpl_expression @@ + bind_map_list abstr_expression @@ pseq_to_list lst.elements in return @@ e_list ~loc lst' | ENil reg -> let loc = Location.lift reg in return @@ e_list ~loc [] -and simpl_set_expression (t:Raw.set_expr) : expression result = +and abstr_set_expression (t:Raw.set_expr) : expression result = match t with | SetMem x -> ( let (x' , loc) = r_split x in - let%bind set' = simpl_expression x'.set in - let%bind element' = simpl_expression x'.element in + let%bind set' = abstr_expression x'.set in + let%bind element' = abstr_expression x'.element in ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ] ) | SetInj x -> ( let (x' , loc) = r_split x in let elements = pseq_to_list x'.elements in - let%bind elements' = bind_map_list simpl_expression elements in + let%bind elements' = bind_map_list abstr_expression elements in ok @@ e_set ~loc elements' ) -and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = +and abstr_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = let return x = ok x in let (t , loc) = r_split t in - let%bind a = simpl_expression t.arg1 in - let%bind b = simpl_expression t.arg2 in + let%bind a = abstr_expression t.arg1 in + let%bind b = abstr_expression t.arg2 in let%bind name = constants name in return @@ e_constant ~loc name [ a ; b ] -and simpl_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = +and abstr_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = let return x = ok x in let (t , loc) = r_split t in - let%bind a = simpl_expression t.arg in + let%bind a = abstr_expression t.arg in let%bind name = constants name in return @@ e_constant ~loc name [ a ] -and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = +and abstr_tuple_expression ?loc (lst:Raw.expr list) : expression result = let return x = ok x in match lst with | [] -> return @@ e_literal Literal_unit - | [hd] -> simpl_expression hd + | [hd] -> abstr_expression hd | lst -> - let%bind lst = bind_list @@ List.map simpl_expression lst + let%bind lst = bind_list @@ List.map abstr_expression lst in return @@ e_tuple ?loc lst -and simpl_data_declaration : Raw.data_decl -> _ result = +and abstr_data_declaration : Raw.data_decl -> _ result = fun t -> match t with | LocalVar x -> let (x , loc) = r_split x in let name = x.name.value in - let%bind t = simpl_type_expression x.var_type in - let%bind expression = simpl_expression x.init in + let%bind t = abstr_type_expression x.var_type in + let%bind expression = abstr_expression x.init in return_let_in ~loc (Var.of_name name, Some t) false false expression | LocalConst x -> let (x , loc) = r_split x in let name = x.name.value in - let%bind t = simpl_type_expression x.const_type in - let%bind expression = simpl_expression x.init in + let%bind t = abstr_type_expression x.const_type in + let%bind expression = abstr_expression x.init in let inline = match x.attributes with None -> false @@ -630,7 +630,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result = in return_let_in ~loc (Var.of_name name, Some t) false inline expression | LocalFun f -> let (f , loc) = r_split f in - let%bind (binder, expr) = simpl_fun_decl ~loc f in + let%bind (binder, expr) = abstr_fun_decl ~loc f in let inline = match f.attributes with None -> false @@ -639,22 +639,22 @@ and simpl_data_declaration : Raw.data_decl -> _ result = |> List.exists (fun Region.{value; _} -> value = "\"inline\"") in return_let_in ~loc binder false inline expr -and simpl_param : +and abstr_param : Raw.param_decl -> (string * type_expression) result = fun t -> match t with | ParamConst c -> let c = c.value in let param_name = c.var.value in - let%bind type_expression = simpl_type_expression c.param_type in + let%bind type_expression = abstr_type_expression c.param_type in ok (param_name , type_expression) | ParamVar v -> let c = v.value in let param_name = c.var.value in - let%bind type_expression = simpl_type_expression c.param_type in + let%bind type_expression = abstr_type_expression c.param_type in ok (param_name , type_expression) -and simpl_fun_decl : +and abstr_fun_decl : loc:_ -> Raw.fun_decl -> ((expression_variable * type_expression option) * expression) result = fun ~loc x -> @@ -674,11 +674,11 @@ and simpl_fun_decl : in (match param.value.inside with a, [] -> ( - let%bind input = simpl_param a in + let%bind input = abstr_param a in let (binder , input_type) = input in - let%bind instructions = simpl_statement_list statements in - let%bind result = simpl_expression return in - let%bind output_type = simpl_type_expression ret_type in + let%bind instructions = abstr_statement_list statements in + let%bind result = abstr_expression return in + let%bind output_type = abstr_type_expression ret_type in let body = instructions in let%bind result = let aux prec cur = cur (Some prec) in @@ -699,7 +699,7 @@ and simpl_fun_decl : let lst = npseq_to_list lst in (* TODO wrong, should be fresh? *) let arguments_name = Var.of_name "arguments" in - let%bind params = bind_map_list simpl_param lst in + let%bind params = bind_map_list abstr_param lst in let (binder , input_type) = let type_expression = t_tuple (List.map snd params) in (arguments_name , type_expression) in @@ -712,9 +712,9 @@ and simpl_fun_decl : ass in bind_list @@ List.mapi aux params in - let%bind instructions = simpl_statement_list statements in - let%bind result = simpl_expression return in - let%bind output_type = simpl_type_expression ret_type in + let%bind instructions = abstr_statement_list statements in + let%bind result = abstr_expression return in + let%bind output_type = abstr_type_expression ret_type in let body = tpl_declarations @ instructions in let%bind result = let aux prec cur = cur (Some prec) in @@ -732,7 +732,7 @@ and simpl_fun_decl : ) ) -and simpl_fun_expression : +and abstr_fun_expression : loc:_ -> Raw.fun_expr -> (type_expression option * expression) result = fun ~loc x -> let open! Raw in @@ -740,11 +740,12 @@ and simpl_fun_expression : let statements = [] in (match param.value.inside with a, [] -> ( - let%bind input = simpl_param a in + let%bind input = abstr_param a in let (binder , input_type) = input in - let%bind instructions = simpl_statement_list statements in - let%bind result = simpl_expression return in - let%bind output_type = simpl_type_expression ret_type in + let%bind instructions = abstr_statement_list statements in + let%bind result = abstr_expression return in + let%bind output_type = abstr_type_expression ret_type in + let body = instructions in let%bind result = let aux prec cur = cur (Some prec) in @@ -762,7 +763,7 @@ and simpl_fun_expression : let lst = npseq_to_list lst in (* TODO wrong, should be fresh? *) let arguments_name = Var.of_name "arguments" in - let%bind params = bind_map_list simpl_param lst in + let%bind params = bind_map_list abstr_param lst in let (binder , input_type) = let type_expression = t_tuple (List.map snd params) in (arguments_name , type_expression) in @@ -774,9 +775,9 @@ and simpl_fun_expression : ass in bind_list @@ List.mapi aux params in - let%bind instructions = simpl_statement_list statements in - let%bind result = simpl_expression return in - let%bind output_type = simpl_type_expression ret_type in + let%bind instructions = abstr_statement_list statements in + let%bind result = abstr_expression return in + let%bind output_type = abstr_type_expression ret_type in let body = tpl_declarations @ instructions in let%bind result = let aux prec cur = cur (Some prec) in @@ -791,7 +792,7 @@ and simpl_fun_expression : ) ) -and simpl_statement_list statements = +and abstr_statement_list statements = let open Raw in let rec hook acc = function [] -> acc @@ -813,9 +814,9 @@ and simpl_statement_list statements = (* Detached attributes are erased. TODO: Warning. *) hook acc statements | Instr i :: statements -> - hook (simpl_instruction i :: acc) statements + hook (abstr_instruction i :: acc) statements | Data d :: statements -> - hook (simpl_data_declaration d :: acc) statements + hook (abstr_data_declaration d :: acc) statements in bind_list @@ hook [] (List.rev statements) and get_case_variables (t:Raw.pattern) : expression_variable list result = @@ -847,7 +848,7 @@ and get_case_variables (t:Raw.pattern) : expression_variable list result = | PVar v -> ok @@ [Var.of_name v.value] | p -> fail @@ unsupported_cst_constr p -and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result = +and abstr_single_instruction : Raw.instruction -> (_ -> expression result) result = fun t -> match t with | ProcCall x -> ( @@ -859,15 +860,15 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let (f_name , f_loc) = r_split name in match constants f_name with | Error _ -> - let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + let%bind arg = abstr_tuple_expression ~loc:args_loc args' in return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg | Ok (s,_) -> - let%bind lst = bind_map_list simpl_expression args' in + let%bind lst = bind_map_list abstr_expression args' in return_statement @@ e_constant ~loc s lst ) | f -> ( - let%bind f' = simpl_expression f in - let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + let%bind f' = abstr_expression f in + let%bind arg = abstr_tuple_expression ~loc:args_loc args' in return_statement @@ e_application ~loc f' arg ) ) @@ -876,35 +877,35 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul return_statement @@ e_skip ~loc () ) | Loop (While l) -> - simpl_while_loop l.value + abstr_while_loop l.value | Loop (For (ForInt fi)) -> ( - let%bind loop = simpl_for_int fi.value in + let%bind loop = abstr_for_int fi.value in ok loop ) | Loop (For (ForCollect fc)) -> - let%bind loop = simpl_for_collect fc.value in + let%bind loop = abstr_for_collect fc.value in ok loop | Cond c -> ( let (c , loc) = r_split c in - let%bind expr = simpl_expression c.test in + let%bind expr = abstr_expression c.test in let%bind match_true = match c.ifso with ClauseInstr i -> - simpl_single_instruction i + abstr_single_instruction i | ClauseBlock b -> match b with LongBlock {value; _} -> - simpl_block value + abstr_block value | ShortBlock {value; _} -> - simpl_statements @@ fst value.inside in + abstr_statements @@ fst value.inside in let%bind match_false = match c.ifnot with ClauseInstr i -> - simpl_single_instruction i + abstr_single_instruction i | ClauseBlock b -> match b with LongBlock {value; _} -> - simpl_block value + abstr_block value | ShortBlock {value; _} -> - simpl_statements @@ fst value.inside in + abstr_statements @@ fst value.inside in let env = Var.fresh () in let%bind match_true' = match_true None in @@ -928,10 +929,10 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul ) | Assign a -> ( let (a , loc) = r_split a in - let%bind value_expr = simpl_expression a.rhs in + let%bind value_expr = abstr_expression a.rhs in match a.lhs with | Path path -> ( - let (name , path') = simpl_path path in + let (name , path') = abstr_path path in let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in return_let_in let_binder mut inline rhs ) @@ -940,11 +941,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let%bind (varname,map,path) = match v'.path with | Name name -> ok (name.value , e_variable (Var.of_name name.value), []) | Path p -> - let (name,p') = simpl_path v'.path in - let%bind accessor = simpl_projection p in + let (name,p') = abstr_path v'.path in + let%bind accessor = abstr_projection p in ok @@ (name , accessor , p') in - let%bind key_expr = simpl_expression v'.index.value.inside in + let%bind key_expr = abstr_expression v'.index.value.inside in let expr' = e_map_add key_expr value_expr map in let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in return_let_in let_binder mut inline rhs @@ -952,20 +953,20 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul ) | CaseInstr c -> ( let (c , loc) = r_split c in - let%bind expr = simpl_expression c.expr in + let%bind expr = abstr_expression c.expr in let env = Var.fresh () in let%bind (fv,cases) = let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) = let%bind case_clause = match x.value.rhs with ClauseInstr i -> - simpl_single_instruction i + abstr_single_instruction i | ClauseBlock b -> match b with LongBlock {value; _} -> - simpl_block value + abstr_block value | ShortBlock {value; _} -> - simpl_statements @@ fst value.inside in + abstr_statements @@ fst value.inside in let%bind case_clause'= case_clause @@ None in let%bind case_clause = case_clause @@ Some(e_variable env) in let%bind case_vars = get_case_variables x.value.pattern in @@ -975,11 +976,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let free_vars = List.concat fv in if (List.length free_vars == 0) then ( let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in - let%bind m = simpl_cases cases in + let%bind m = abstr_cases cases in return_statement @@ e_matching ~loc expr m ) else ( let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in - let%bind m = simpl_cases cases in + let%bind m = abstr_cases cases in let match_expr = e_matching ~loc expr m in let return_expr = fun expr -> e_let_in (env,None) false false (store_mutable_variable free_vars) @@ @@ -1001,8 +1002,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul region=r.record_inj.region } in let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in - let%bind expr = simpl_update {value=u;region=reg} in - let (name , access_path) = simpl_path r.path in + let%bind expr = abstr_update {value=u;region=reg} in + let (name , access_path) = abstr_path r.path in let loc = Some loc in let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in return_let_in binder mut inline rhs @@ -1010,13 +1011,13 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul ) | MapPatch patch -> ( let (map_p, loc) = r_split patch in - let (name, access_path) = simpl_path map_p.path in + let (name, access_path) = abstr_path map_p.path in let%bind inj = bind_list @@ List.map (fun (x:Raw.binding Region.reg) -> let x = x.value in let (key, value) = x.source, x.image in - let%bind key' = simpl_expression key in - let%bind value' = simpl_expression value + let%bind key' = abstr_expression key in + let%bind value' = abstr_expression value in ok @@ (key', value') ) @@ npseq_to_list map_p.map_inj.value.ne_elements in @@ -1033,10 +1034,10 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul ) | SetPatch patch -> ( let (setp, loc) = r_split patch in - let (name , access_path) = simpl_path setp.path in + let (name , access_path) = abstr_path setp.path in let%bind inj = bind_list @@ - List.map simpl_expression @@ + List.map abstr_expression @@ npseq_to_list setp.set_inj.value.ne_elements in match inj with | [] -> return_statement @@ e_skip ~loc () @@ -1053,11 +1054,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let%bind (varname,map,path) = match v.map with | Name v -> ok (v.value , e_variable (Var.of_name v.value) , []) | Path p -> - let (name,p') = simpl_path v.map in - let%bind accessor = simpl_projection p in + let (name,p') = abstr_path v.map in + let%bind accessor = abstr_projection p in ok @@ (name , accessor , p') in - let%bind key' = simpl_expression key in + let%bind key' = abstr_expression key in let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in return_let_in binder mut inline rhs @@ -1067,17 +1068,17 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let%bind (varname, set, path) = match set_rm.set with | Name v -> ok (v.value, e_variable (Var.of_name v.value), []) | Path path -> - let(name, p') = simpl_path set_rm.set in - let%bind accessor = simpl_projection path in + let(name, p') = abstr_path set_rm.set in + let%bind accessor = abstr_projection path in ok @@ (name, accessor, p') in - let%bind removed' = simpl_expression set_rm.element in + let%bind removed' = abstr_expression set_rm.element in let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in return_let_in binder mut inline rhs ) -and simpl_path : Raw.path -> string * string list = fun p -> +and abstr_path : Raw.path -> string * string list = fun p -> match p with | Raw.Name v -> (v.value , []) | Raw.Path p -> ( @@ -1094,7 +1095,7 @@ and simpl_path : Raw.path -> string * string list = fun p -> (var , path') ) -and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun t -> +and abstr_cases : (Raw.pattern * expression) list -> matching_expr result = fun t -> let open Raw in let get_var (t:Raw.pattern) = match t with @@ -1185,13 +1186,13 @@ and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun bind_map_list aux lst in ok @@ ez_match_variant constrs -and simpl_instruction : Raw.instruction -> (_ -> expression result) result = - fun t -> trace (simplifying_instruction t) @@ simpl_single_instruction t +and abstr_instruction : Raw.instruction -> (_ -> expression result) result = + fun t -> trace (abstracting_instruction t) @@ abstr_single_instruction t -and simpl_statements : Raw.statements -> (_ -> expression result) result = +and abstr_statements : Raw.statements -> (_ -> expression result) result = fun statements -> let lst = npseq_to_list statements in - let%bind fs = simpl_statement_list lst in + let%bind fs = abstr_statement_list lst in let aux : _ -> (expression option -> expression result) -> _ = fun prec cur -> let%bind res = cur prec @@ -1200,19 +1201,19 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result = let%bind ret = bind_fold_right_list aux expr' fs in ok @@ Option.unopt_exn ret -and simpl_block : Raw.block -> (_ -> expression result) result = - fun t -> simpl_statements t.statements +and abstr_block : Raw.block -> (_ -> expression result) result = + fun t -> abstr_statements t.statements -and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl -> +and abstr_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl -> let env_rec = Var.fresh () in let binder = Var.fresh () in - let%bind cond = simpl_expression wl.cond in + let%bind cond = abstr_expression wl.cond in let ctrl = (e_variable binder) in - let%bind for_body = simpl_block wl.block.value in + let%bind for_body = abstr_block wl.block.value in let%bind for_body = for_body @@ Some( ctrl ) in let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in @@ -1237,15 +1238,15 @@ and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun w restore_mutable_variable return_expr captured_name_list env_rec -and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> +and abstr_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> let env_rec = Var.fresh () in let binder = Var.fresh () in let name = fi.assign.value.name.value in let it = Var.of_name name in let var = e_variable it in (*Make the cond and the step *) - let%bind value = simpl_expression fi.assign.value.expr in - let%bind bound = simpl_expression fi.bound in + let%bind value = abstr_expression fi.assign.value.expr in + let%bind bound = abstr_expression fi.bound in let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in let step = e_int 1 in let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in @@ -1255,7 +1256,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> continue_expr in (* Modify the body loop*) - let%bind for_body = simpl_block fi.block.value in + let%bind for_body = abstr_block fi.block.value in let%bind for_body = for_body @@ Some ctrl in let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in @@ -1285,19 +1286,19 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> in restore_mutable_variable return_expr captured_name_list env_rec -and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> +and abstr_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> let binder = Var.of_name "arguments" in let%bind element_names = ok @@ match fc.bind_to with | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] | None -> [Var.of_name fc.var.value] in let env = Var.fresh () in - let%bind for_body = simpl_block fc.block.value in + let%bind for_body = abstr_block fc.block.value in let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in let init_record = store_mutable_variable free_vars in - let%bind collect = simpl_expression fc.expr in + let%bind collect = abstr_expression fc.expr in let aux name expr= e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr in @@ -1319,8 +1320,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun in restore_mutable_variable fold free_vars env -and simpl_declaration_list declarations : - Ast_simplified.declaration Location.wrap list result = +and abstr_declaration_list declarations : declaration Location.wrap list result = let open Raw in let rec hook acc = function [] -> acc @@ -1344,16 +1344,16 @@ and simpl_declaration_list declarations : | TypeDecl decl :: declarations -> let decl, loc = r_split decl in let {name; type_expr} : Raw.type_decl = decl in - let%bind type_expression = simpl_type_expression type_expr in + let%bind type_expression = abstr_type_expression type_expr in let new_decl = Declaration_type (Var.of_name name.value, type_expression) in let res = Location.wrap ~loc new_decl in hook (bind_list_cons res acc) declarations | ConstDecl decl :: declarations -> - let simpl_const_decl = + let abstr_const_decl = fun {name;const_type; init; attributes} -> - let%bind expression = simpl_expression init in - let%bind t = simpl_type_expression const_type in + let%bind expression = abstr_expression init in + let%bind t = abstr_type_expression const_type in let type_annotation = Some t in let inline = match attributes with @@ -1366,11 +1366,11 @@ and simpl_declaration_list declarations : (Var.of_name name.value, type_annotation, inline, expression) in ok new_decl in let%bind res = - bind_map_location simpl_const_decl (Location.lift_region decl) + bind_map_location abstr_const_decl (Location.lift_region decl) in hook (bind_list_cons res acc) declarations | FunDecl fun_decl :: declarations -> let decl, loc = r_split fun_decl in - let%bind ((name, ty_opt), expr) = simpl_fun_decl ~loc decl in + let%bind ((name, ty_opt), expr) = abstr_fun_decl ~loc decl in let inline = match fun_decl.value.attributes with None -> false @@ -1383,5 +1383,5 @@ and simpl_declaration_list declarations : hook (bind_list_cons res acc) declarations in hook (ok @@ []) (List.rev declarations) -let simpl_program : Raw.ast -> program result = - fun t -> simpl_declaration_list @@ nseq_to_list t.decl +let abstr_program : Raw.ast -> program result = + fun t -> abstr_declaration_list @@ nseq_to_list t.decl diff --git a/src/passes/2-simplify/pascaligo.mli b/src/passes/2-abstracter/pascaligo.mli similarity index 76% rename from src/passes/2-simplify/pascaligo.mli rename to src/passes/2-abstracter/pascaligo.mli index 42e5e4afe..652c77d99 100644 --- a/src/passes/2-simplify/pascaligo.mli +++ b/src/passes/2-abstracter/pascaligo.mli @@ -1,15 +1,15 @@ (** Converts PascaLIGO programs to the Simplified Abstract Syntax Tree. *) open Trace -open Ast_simplified +open Ast_imperative module Raw = Parser.Pascaligo.AST module SMap = Map.String (** Convert a concrete PascaLIGO expression AST to the simplified expression AST used by the compiler. *) -val simpl_expression : Raw.expr -> expr result +val abstr_expression : Raw.expr -> expr result (** Convert a concrete PascaLIGO program AST to the simplified program AST used by the compiler. *) -val simpl_program : Raw.ast -> program result +val abstr_program : Raw.ast -> program result diff --git a/src/passes/3-self_ast_imperative/dune b/src/passes/3-self_ast_imperative/dune new file mode 100644 index 000000000..2b1e5f8b5 --- /dev/null +++ b/src/passes/3-self_ast_imperative/dune @@ -0,0 +1,13 @@ +(library + (name self_ast_imperative) + (public_name ligo.self_ast_imperative) + (libraries + simple-utils + ast_imperative + proto-alpha-utils + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml b/src/passes/3-self_ast_imperative/entrypoints_lenght_limit.ml similarity index 97% rename from src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml rename to src/passes/3-self_ast_imperative/entrypoints_lenght_limit.ml index a64007b4a..f2d5fc202 100644 --- a/src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml +++ b/src/passes/3-self_ast_imperative/entrypoints_lenght_limit.ml @@ -1,4 +1,4 @@ -open Ast_simplified +open Ast_imperative open Trace open Stage_common.Helpers diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml similarity index 99% rename from src/passes/3-self_ast_simplified/helpers.ml rename to src/passes/3-self_ast_imperative/helpers.ml index 101f8d9ab..22e426700 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -1,4 +1,4 @@ -open Ast_simplified +open Ast_imperative open Trace open Stage_common.Helpers diff --git a/src/passes/3-self_ast_simplified/literals.ml b/src/passes/3-self_ast_imperative/literals.ml similarity index 98% rename from src/passes/3-self_ast_simplified/literals.ml rename to src/passes/3-self_ast_imperative/literals.ml index 367e9787f..96914359a 100644 --- a/src/passes/3-self_ast_simplified/literals.ml +++ b/src/passes/3-self_ast_imperative/literals.ml @@ -1,4 +1,4 @@ -open Ast_simplified +open Ast_imperative open Trace open Proto_alpha_utils @@ -6,7 +6,7 @@ module Errors = struct let bad_format e () = let title = (thunk ("Badly formatted literal")) in - let message () = Format.asprintf "%a" Ast_simplified.PP.expression e in + let message () = Format.asprintf "%a" PP.expression e in let data = [ ("location" , fun () -> Format.asprintf "%a" Location.pp e.location) ] in diff --git a/src/passes/3-self_ast_simplified/none_variant.ml b/src/passes/3-self_ast_imperative/none_variant.ml similarity index 95% rename from src/passes/3-self_ast_simplified/none_variant.ml rename to src/passes/3-self_ast_imperative/none_variant.ml index 416142f0f..894d55830 100644 --- a/src/passes/3-self_ast_simplified/none_variant.ml +++ b/src/passes/3-self_ast_imperative/none_variant.ml @@ -1,4 +1,4 @@ -open Ast_simplified +open Ast_imperative open Trace let peephole_expression : expression -> expression result = fun e -> diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_imperative/self_ast_imperative.ml similarity index 100% rename from src/passes/3-self_ast_simplified/self_ast_simplified.ml rename to src/passes/3-self_ast_imperative/self_ast_imperative.ml diff --git a/src/passes/3-self_ast_simplified/tezos_type_annotation.ml b/src/passes/3-self_ast_imperative/tezos_type_annotation.ml similarity index 98% rename from src/passes/3-self_ast_simplified/tezos_type_annotation.ml rename to src/passes/3-self_ast_imperative/tezos_type_annotation.ml index cc6557ae2..19118f125 100644 --- a/src/passes/3-self_ast_simplified/tezos_type_annotation.ml +++ b/src/passes/3-self_ast_imperative/tezos_type_annotation.ml @@ -1,4 +1,4 @@ -open Ast_simplified +open Ast_imperative open Trace module Errors = struct diff --git a/src/passes/4-Instruction_remover/dune b/src/passes/4-Instruction_remover/dune new file mode 100644 index 000000000..eb702bf26 --- /dev/null +++ b/src/passes/4-Instruction_remover/dune @@ -0,0 +1,14 @@ +(library + (name instruction_remover) + (public_name ligo.instruction_remover) + (libraries + simple-utils + ast_imperative + ast_complex + proto-alpha-utils + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/4-Instruction_remover/instruction_remover.ml b/src/passes/4-Instruction_remover/instruction_remover.ml new file mode 100644 index 000000000..816ed47b9 --- /dev/null +++ b/src/passes/4-Instruction_remover/instruction_remover.ml @@ -0,0 +1,186 @@ +module I = Ast_imperative +module O = Ast_complex +open Trace + +let rec idle_type_expression : I.type_expression -> O.type_expression result = + fun te -> + let return te = ok @@ O.make_t te in + match te.type_content with + | I.T_sum sum -> + let sum = I.CMap.to_kv_list sum in + let%bind sum = + bind_map_list (fun (k,v) -> + let%bind v = idle_type_expression v in + ok @@ (k,v) + ) sum + in + return @@ O.T_sum (O.CMap.of_list sum) + | I.T_record record -> + let record = I.LMap.to_kv_list record in + let%bind record = + bind_map_list (fun (k,v) -> + let%bind v = idle_type_expression v in + ok @@ (k,v) + ) record + in + return @@ O.T_record (O.LMap.of_list record) + | I.T_arrow {type1;type2} -> + let%bind type1 = idle_type_expression type1 in + let%bind type2 = idle_type_expression type2 in + return @@ T_arrow {type1;type2} + | I.T_variable type_variable -> return @@ T_variable type_variable + | I.T_constant type_constant -> return @@ T_constant type_constant + | I.T_operator type_operator -> + let%bind type_operator = idle_type_operator type_operator in + return @@ T_operator type_operator + +and idle_type_operator : I.type_operator -> O.type_operator result = + fun t_o -> + match t_o with + | TC_contract c -> + let%bind c = idle_type_expression c in + ok @@ O.TC_contract c + | TC_option o -> + let%bind o = idle_type_expression o in + ok @@ O.TC_option o + | TC_list l -> + let%bind l = idle_type_expression l in + ok @@ O.TC_list l + | TC_set s -> + let%bind s = idle_type_expression s in + ok @@ O.TC_set s + | TC_map (k,v) -> + let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in + ok @@ O.TC_map (k,v) + | TC_big_map (k,v) -> + let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in + ok @@ O.TC_big_map (k,v) + | TC_arrow (i,o) -> + let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in + ok @@ O.TC_arrow (i,o) + +let rec remove_instruction_in_expression : I.expression -> O.expression result = + fun e -> + let return expr = ok @@ O.make_expr ~loc:e.location expr in + match e.expression_content with + | I.E_literal literal -> return @@ O.E_literal literal + | I.E_constant {cons_name;arguments} -> + let%bind arguments = bind_map_list remove_instruction_in_expression arguments in + return @@ O.E_constant {cons_name;arguments} + | I.E_variable name -> return @@ O.E_variable name + | I.E_application {expr1;expr2} -> + let%bind expr1 = remove_instruction_in_expression expr1 in + let%bind expr2 = remove_instruction_in_expression expr2 in + return @@ O.E_application {expr1; expr2} + | I.E_lambda lambda -> + let%bind lambda = remove_instruction_in_lambda lambda in + return @@ O.E_lambda lambda + | I.E_recursive {fun_name;fun_type;lambda} -> + let%bind fun_type = idle_type_expression fun_type in + let%bind lambda = remove_instruction_in_lambda lambda in + return @@ O.E_recursive {fun_name;fun_type;lambda} + | I.E_let_in {let_binder;mut=_;inline;rhs;let_result} -> + let (binder,ty_opt) = let_binder in + let%bind ty_opt = bind_map_option idle_type_expression ty_opt in + let%bind rhs = remove_instruction_in_expression rhs in + let%bind let_result = remove_instruction_in_expression let_result in + return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} + | I.E_skip -> return @@ O.E_skip + | I.E_constructor {constructor;element} -> + let%bind element = remove_instruction_in_expression element in + return @@ O.E_constructor {constructor;element} + | I.E_matching {matchee; cases} -> + let%bind matchee = remove_instruction_in_expression matchee in + let%bind cases = remove_instruction_in_matching cases in + return @@ O.E_matching {matchee;cases} + | I.E_record record -> + let record = I.LMap.to_kv_list record in + let%bind record = + bind_map_list (fun (k,v) -> + let%bind v =remove_instruction_in_expression v in + ok @@ (k,v) + ) record + in + return @@ O.E_record (O.LMap.of_list record) + | I.E_record_accessor {expr;label} -> + let%bind expr = remove_instruction_in_expression expr in + return @@ O.E_record_accessor {expr;label} + | I.E_record_update {record;path;update} -> + let%bind record = remove_instruction_in_expression record in + let%bind update = remove_instruction_in_expression update in + return @@ O.E_record_update {record;path;update} + | I.E_map map -> + let%bind map = bind_map_list ( + bind_map_pair remove_instruction_in_expression + ) map + in + return @@ O.E_map map + | I.E_big_map big_map -> + let%bind big_map = bind_map_list ( + bind_map_pair remove_instruction_in_expression + ) big_map + in + return @@ O.E_big_map big_map + | I.E_list lst -> + let%bind lst = bind_map_list remove_instruction_in_expression lst in + return @@ O.E_list lst + | I.E_set set -> + let%bind set = bind_map_list remove_instruction_in_expression set in + return @@ O.E_set set + | I.E_look_up look_up -> + let%bind look_up = bind_map_pair remove_instruction_in_expression look_up in + return @@ O.E_look_up look_up + | I.E_ascription {anno_expr; type_annotation} -> + let%bind anno_expr = remove_instruction_in_expression anno_expr in + let%bind type_annotation = idle_type_expression type_annotation in + return @@ O.E_ascription {anno_expr; type_annotation} +and remove_instruction_in_lambda : I.lambda -> O.lambda result = + fun {binder;input_type;output_type;result}-> + let%bind input_type = bind_map_option idle_type_expression input_type in + let%bind output_type = bind_map_option idle_type_expression output_type in + let%bind result = remove_instruction_in_expression result in + ok @@ O.{binder;input_type;output_type;result} +and remove_instruction_in_matching : I.matching_expr -> O.matching_expr result = + fun m -> + match m with + | I.Match_bool {match_true;match_false} -> + let%bind match_true = remove_instruction_in_expression match_true in + let%bind match_false = remove_instruction_in_expression match_false in + ok @@ O.Match_bool {match_true;match_false} + | I.Match_list {match_nil;match_cons} -> + let%bind match_nil = remove_instruction_in_expression match_nil in + let (hd,tl,expr,tv) = match_cons in + let%bind expr = remove_instruction_in_expression expr in + ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + | I.Match_option {match_none;match_some} -> + let%bind match_none = remove_instruction_in_expression match_none in + let (n,expr,tv) = match_some in + let%bind expr = remove_instruction_in_expression expr in + ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} + | I.Match_tuple ((lst,expr), tv) -> + let%bind expr = remove_instruction_in_expression expr in + ok @@ O.Match_tuple ((lst,expr), tv) + | I.Match_variant (lst,tv) -> + let%bind lst = bind_map_list ( + fun ((c,n),expr) -> + let%bind expr = remove_instruction_in_expression expr in + ok @@ ((c,n),expr) + ) lst + in + ok @@ O.Match_variant (lst,tv) + +let remove_instruction_in_declaration : I.declaration Location.wrap -> _ = + fun {wrap_content=declaration;location} -> + let return decl = ok @@ Location.wrap ~loc:location decl in + match declaration with + | I.Declaration_constant (n, te_opt, inline, expr) -> + let%bind expr = remove_instruction_in_expression expr in + let%bind te_opt = bind_map_option idle_type_expression te_opt in + return @@ O.Declaration_constant (n, te_opt, inline, expr) + | I.Declaration_type (n, te) -> + let%bind te = idle_type_expression te in + return @@ O.Declaration_type (n,te) + +let remove_instruction_in_program : I.program -> O.program result = + fun p -> + bind_map_list remove_instruction_in_declaration p diff --git a/src/passes/5-self_ast_complex/dune b/src/passes/5-self_ast_complex/dune new file mode 100644 index 000000000..819a5ad1f --- /dev/null +++ b/src/passes/5-self_ast_complex/dune @@ -0,0 +1,13 @@ +(library + (name self_ast_complex) + (public_name ligo.self_ast_complex) + (libraries + simple-utils + ast_complex + proto-alpha-utils + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/5-self_ast_typed/main.ml b/src/passes/5-self_ast_typed/main.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/passes/6-simplifier/dune b/src/passes/6-simplifier/dune new file mode 100644 index 000000000..a693dcd19 --- /dev/null +++ b/src/passes/6-simplifier/dune @@ -0,0 +1,14 @@ +(library + (name simplifier) + (public_name ligo.simplifier) + (libraries + simple-utils + ast_complex + ast_simplified + proto-alpha-utils + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/6-simplifier/simplifier.ml b/src/passes/6-simplifier/simplifier.ml new file mode 100644 index 000000000..fd396705e --- /dev/null +++ b/src/passes/6-simplifier/simplifier.ml @@ -0,0 +1,187 @@ +module I = Ast_complex +module O = Ast_simplified +open Trace + +let rec idle_type_expression : I.type_expression -> O.type_expression result = + fun te -> + let return te = ok @@ O.make_t te in + match te.type_content with + | I.T_sum sum -> + let sum = I.CMap.to_kv_list sum in + let%bind sum = + bind_map_list (fun (k,v) -> + let%bind v = idle_type_expression v in + ok @@ (k,v) + ) sum + in + return @@ O.T_sum (O.CMap.of_list sum) + | I.T_record record -> + let record = I.LMap.to_kv_list record in + let%bind record = + bind_map_list (fun (k,v) -> + let%bind v = idle_type_expression v in + ok @@ (k,v) + ) record + in + return @@ O.T_record (O.LMap.of_list record) + | I.T_arrow {type1;type2} -> + let%bind type1 = idle_type_expression type1 in + let%bind type2 = idle_type_expression type2 in + return @@ T_arrow {type1;type2} + | I.T_variable type_variable -> return @@ T_variable type_variable + | I.T_constant type_constant -> return @@ T_constant type_constant + | I.T_operator type_operator -> + let%bind type_operator = idle_type_operator type_operator in + return @@ T_operator type_operator + +and idle_type_operator : I.type_operator -> O.type_operator result = + fun t_o -> + match t_o with + | TC_contract c -> + let%bind c = idle_type_expression c in + ok @@ O.TC_contract c + | TC_option o -> + let%bind o = idle_type_expression o in + ok @@ O.TC_option o + | TC_list l -> + let%bind l = idle_type_expression l in + ok @@ O.TC_list l + | TC_set s -> + let%bind s = idle_type_expression s in + ok @@ O.TC_set s + | TC_map (k,v) -> + let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in + ok @@ O.TC_map (k,v) + | TC_big_map (k,v) -> + let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in + ok @@ O.TC_big_map (k,v) + | TC_arrow (i,o) -> + let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in + ok @@ O.TC_arrow (i,o) + +let rec simplify_expression : I.expression -> O.expression result = + fun e -> + let return expr = ok @@ O.make_expr ~loc:e.location expr in + match e.expression_content with + | I.E_literal literal -> return @@ O.E_literal literal + | I.E_constant {cons_name;arguments} -> + let%bind arguments = bind_map_list simplify_expression arguments in + return @@ O.E_constant {cons_name;arguments} + | I.E_variable name -> return @@ O.E_variable name + | I.E_application {expr1;expr2} -> + let%bind expr1 = simplify_expression expr1 in + let%bind expr2 = simplify_expression expr2 in + return @@ O.E_application {expr1; expr2} + | I.E_lambda lambda -> + let%bind lambda = simplify_lambda lambda in + return @@ O.E_lambda lambda + | I.E_recursive {fun_name;fun_type;lambda} -> + let%bind fun_type = idle_type_expression fun_type in + let%bind lambda = simplify_lambda lambda in + return @@ O.E_recursive {fun_name;fun_type;lambda} + | I.E_let_in {let_binder;inline;rhs;let_result} -> + let (binder,ty_opt) = let_binder in + let%bind ty_opt = bind_map_option idle_type_expression ty_opt in + let%bind rhs = simplify_expression rhs in + let%bind let_result = simplify_expression let_result in + return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} + | I.E_skip -> return @@ O.E_skip + | I.E_constructor {constructor;element} -> + let%bind element = simplify_expression element in + return @@ O.E_constructor {constructor;element} + | I.E_matching {matchee; cases} -> + let%bind matchee = simplify_expression matchee in + let%bind cases = simplify_matching cases in + return @@ O.E_matching {matchee;cases} + | I.E_record record -> + let record = I.LMap.to_kv_list record in + let%bind record = + bind_map_list (fun (k,v) -> + let%bind v =simplify_expression v in + ok @@ (k,v) + ) record + in + return @@ O.E_record (O.LMap.of_list record) + | I.E_record_accessor {expr;label} -> + let%bind expr = simplify_expression expr in + return @@ O.E_record_accessor {expr;label} + | I.E_record_update {record;path;update} -> + let%bind record = simplify_expression record in + let%bind update = simplify_expression update in + return @@ O.E_record_update {record;path;update} + | I.E_map map -> + let%bind map = bind_map_list ( + bind_map_pair simplify_expression + ) map + in + return @@ O.E_map map + | I.E_big_map big_map -> + let%bind big_map = bind_map_list ( + bind_map_pair simplify_expression + ) big_map + in + return @@ O.E_big_map big_map + | I.E_list lst -> + let%bind lst = bind_map_list simplify_expression lst in + return @@ O.E_list lst + | I.E_set set -> + let%bind set = bind_map_list simplify_expression set in + return @@ O.E_set set + | I.E_look_up look_up -> + let%bind look_up = bind_map_pair simplify_expression look_up in + return @@ O.E_look_up look_up + | I.E_ascription {anno_expr; type_annotation} -> + let%bind anno_expr = simplify_expression anno_expr in + let%bind type_annotation = idle_type_expression type_annotation in + return @@ O.E_ascription {anno_expr; type_annotation} + +and simplify_lambda : I.lambda -> O.lambda result = + fun {binder;input_type;output_type;result}-> + let%bind input_type = bind_map_option idle_type_expression input_type in + let%bind output_type = bind_map_option idle_type_expression output_type in + let%bind result = simplify_expression result in + ok @@ O.{binder;input_type;output_type;result} +and simplify_matching : I.matching_expr -> O.matching_expr result = + fun m -> + match m with + | I.Match_bool {match_true;match_false} -> + let%bind match_true = simplify_expression match_true in + let%bind match_false = simplify_expression match_false in + ok @@ O.Match_bool {match_true;match_false} + | I.Match_list {match_nil;match_cons} -> + let%bind match_nil = simplify_expression match_nil in + let (hd,tl,expr,tv) = match_cons in + let%bind expr = simplify_expression expr in + ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + | I.Match_option {match_none;match_some} -> + let%bind match_none = simplify_expression match_none in + let (n,expr,tv) = match_some in + let%bind expr = simplify_expression expr in + ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} + | I.Match_tuple ((lst,expr), tv) -> + let%bind expr = simplify_expression expr in + ok @@ O.Match_tuple ((lst,expr), tv) + | I.Match_variant (lst,tv) -> + let%bind lst = bind_map_list ( + fun ((c,n),expr) -> + let%bind expr = simplify_expression expr in + ok @@ ((c,n),expr) + ) lst + in + ok @@ O.Match_variant (lst,tv) + +let simplify_declaration : I.declaration Location.wrap -> _ = + fun {wrap_content=declaration;location} -> + let return decl = ok @@ Location.wrap ~loc:location decl in + match declaration with + | I.Declaration_constant (n, te_opt, inline, expr) -> + let%bind expr = simplify_expression expr in + let%bind te_opt = bind_map_option idle_type_expression te_opt in + return @@ O.Declaration_constant (n, te_opt, inline, expr) + | I.Declaration_type (n, te) -> + let%bind te = idle_type_expression te in + return @@ O.Declaration_type (n,te) + +let simplify_program : I.program -> O.program result = + fun p -> + bind_map_list simplify_declaration p diff --git a/src/passes/3-self_ast_simplified/dune b/src/passes/7-self_ast_simplified/dune similarity index 100% rename from src/passes/3-self_ast_simplified/dune rename to src/passes/7-self_ast_simplified/dune diff --git a/src/passes/4-typer-new/PP.ml b/src/passes/8-typer-new/PP.ml similarity index 100% rename from src/passes/4-typer-new/PP.ml rename to src/passes/8-typer-new/PP.ml diff --git a/src/passes/4-typer-new/dune b/src/passes/8-typer-new/dune similarity index 100% rename from src/passes/4-typer-new/dune rename to src/passes/8-typer-new/dune diff --git a/src/passes/4-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml similarity index 100% rename from src/passes/4-typer-new/solver.ml rename to src/passes/8-typer-new/solver.ml diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml similarity index 99% rename from src/passes/4-typer-new/typer.ml rename to src/passes/8-typer-new/typer.ml index decd197fc..a796d0ede 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -1094,7 +1094,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind tv = untype_type_value rhs.type_expression in let%bind rhs = untype_expression rhs in let%bind result = untype_expression let_result in - return (e_let_in (let_binder , (Some tv)) false inline rhs result) + return (e_let_in (let_binder , (Some tv)) inline rhs result) | E_recursive {fun_name; fun_type; lambda} -> let%bind lambda = untype_lambda fun_type lambda in let%bind fun_type = untype_type_expression fun_type in diff --git a/src/passes/4-typer-new/typer.ml.old b/src/passes/8-typer-new/typer.ml.old similarity index 100% rename from src/passes/4-typer-new/typer.ml.old rename to src/passes/8-typer-new/typer.ml.old diff --git a/src/passes/4-typer-new/typer.mli b/src/passes/8-typer-new/typer.mli similarity index 100% rename from src/passes/4-typer-new/typer.mli rename to src/passes/8-typer-new/typer.mli diff --git a/src/passes/4-typer-new/typer_new.ml b/src/passes/8-typer-new/typer_new.ml similarity index 100% rename from src/passes/4-typer-new/typer_new.ml rename to src/passes/8-typer-new/typer_new.ml diff --git a/src/passes/4-typer-old/dune b/src/passes/8-typer-old/dune similarity index 100% rename from src/passes/4-typer-old/dune rename to src/passes/8-typer-old/dune diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml similarity index 99% rename from src/passes/4-typer-old/typer.ml rename to src/passes/8-typer-old/typer.ml index 448f7be08..e1cf018e2 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -893,7 +893,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind tv = untype_type_expression rhs.type_expression in let%bind rhs = untype_expression rhs in let%bind result = untype_expression let_result in - return (e_let_in (let_binder , (Some tv)) false inline rhs result) + return (e_let_in (let_binder , (Some tv)) inline rhs 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 diff --git a/src/passes/4-typer-old/typer.mli b/src/passes/8-typer-old/typer.mli similarity index 100% rename from src/passes/4-typer-old/typer.mli rename to src/passes/8-typer-old/typer.mli diff --git a/src/passes/4-typer-old/typer_old.ml b/src/passes/8-typer-old/typer_old.ml similarity index 100% rename from src/passes/4-typer-old/typer_old.ml rename to src/passes/8-typer-old/typer_old.ml diff --git a/src/passes/4-typer/dune b/src/passes/8-typer/dune similarity index 100% rename from src/passes/4-typer/dune rename to src/passes/8-typer/dune diff --git a/src/passes/4-typer/typer.ml b/src/passes/8-typer/typer.ml similarity index 100% rename from src/passes/4-typer/typer.ml rename to src/passes/8-typer/typer.ml diff --git a/src/passes/4-typer/typer.mli b/src/passes/8-typer/typer.mli similarity index 100% rename from src/passes/4-typer/typer.mli rename to src/passes/8-typer/typer.mli diff --git a/src/passes/5-self_ast_typed/contract_passes.ml b/src/passes/9-self_ast_typed/contract_passes.ml similarity index 100% rename from src/passes/5-self_ast_typed/contract_passes.ml rename to src/passes/9-self_ast_typed/contract_passes.ml diff --git a/src/passes/5-self_ast_typed/dune b/src/passes/9-self_ast_typed/dune similarity index 100% rename from src/passes/5-self_ast_typed/dune rename to src/passes/9-self_ast_typed/dune diff --git a/src/passes/5-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml similarity index 100% rename from src/passes/5-self_ast_typed/helpers.ml rename to src/passes/9-self_ast_typed/helpers.ml diff --git a/src/passes/5-self_ast_typed/self_ast_typed.ml b/src/passes/9-self_ast_typed/self_ast_typed.ml similarity index 100% rename from src/passes/5-self_ast_typed/self_ast_typed.ml rename to src/passes/9-self_ast_typed/self_ast_typed.ml diff --git a/src/passes/5-self_ast_typed/tail_recursion.ml b/src/passes/9-self_ast_typed/tail_recursion.ml similarity index 100% rename from src/passes/5-self_ast_typed/tail_recursion.ml rename to src/passes/9-self_ast_typed/tail_recursion.ml diff --git a/src/passes/9-self_michelson/main.ml b/src/passes/9-self_michelson/main.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/passes/operators/dune b/src/passes/operators/dune index 64222a117..4eb539830 100644 --- a/src/passes/operators/dune +++ b/src/passes/operators/dune @@ -4,6 +4,9 @@ (libraries simple-utils tezos-utils + ast_imperative + ast_complex + ast_simplified ast_typed typesystem mini_c diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index deb541216..abd16ae55 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -9,9 +9,9 @@ open Trace a new constructor at all those places. *) -module Simplify = struct +module Abstracter = struct - open Ast_simplified + open Ast_imperative (* Each front-end has its owns constants. diff --git a/src/passes/operators/operators.mli b/src/passes/operators/operators.mli index 77ce53196..1b33bb811 100644 --- a/src/passes/operators/operators.mli +++ b/src/passes/operators/operators.mli @@ -1,6 +1,6 @@ -module Simplify : sig - open Ast_simplified +module Abstracter : sig + open Ast_imperative open Trace module Pascaligo : sig diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/1-ast_imperative/PP.ml similarity index 99% rename from src/stages/ast_simplified/PP.ml rename to src/stages/1-ast_imperative/PP.ml index f27d9ed70..576575d69 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -4,7 +4,7 @@ open Format open PP_helpers include Stage_common.PP -include Ast_PP_type(Ast_simplified_parameter) +include Ast_PP_type(Ast_imperative_parameter) let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev @@ -52,13 +52,13 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "match %a with %a" expression matchee (matching expression) cases - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> - fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result | E_recursive { fun_name; fun_type; lambda} -> fprintf ppf "rec (%a:%a => %a )" expression_variable fun_name type_expression fun_type expression_content (E_lambda lambda) + | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> + fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result | E_skip -> fprintf ppf "skip" | E_ascription {anno_expr; type_annotation} -> diff --git a/src/stages/ast_simplified/ast_simplified.ml b/src/stages/1-ast_imperative/ast_imperative.ml similarity index 100% rename from src/stages/ast_simplified/ast_simplified.ml rename to src/stages/1-ast_imperative/ast_imperative.ml diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/1-ast_imperative/combinators.ml similarity index 71% rename from src/stages/ast_simplified/combinators.ml rename to src/stages/1-ast_imperative/combinators.ml index 24b292c4f..a37a1b7ef 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -79,56 +79,56 @@ let t_operator op lst: type_expression result = | TC_contract _ , [t] -> ok @@ t_contract t | _ , _ -> fail @@ bad_type_operator op -let location_wrap ?(loc = Location.generated) expression_content = +let make_expr ?(loc = Location.generated) expression_content = let location = loc in { expression_content; location } -let e_var ?loc (n: string) : expression = location_wrap ?loc @@ E_variable (Var.of_name n) -let e_literal ?loc l : expression = location_wrap ?loc @@ E_literal l -let e_unit ?loc () : expression = location_wrap ?loc @@ E_literal (Literal_unit) -let e_int ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_int n) -let e_nat ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_nat n) -let e_timestamp ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_timestamp n) -let e_bool ?loc b : expression = location_wrap ?loc @@ E_literal (Literal_bool b) -let e_string ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_string s) -let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_address s) -let e_mutez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_mutez s) -let e_signature ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_signature s) -let e_key ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key s) -let e_key_hash ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key_hash s) -let e_chain_id ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_chain_id s) +let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n) +let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l +let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit) +let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n) +let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n) +let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n) +let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b) +let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s) +let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s) +let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s) +let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s) +let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s) +let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s) +let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s) let e'_bytes b : expression_content result = let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in ok @@ E_literal (Literal_bytes bytes) let e_bytes_hex ?loc b : expression result = let%bind e' = e'_bytes b in - ok @@ location_wrap ?loc e' + ok @@ make_expr ?loc e' let e_bytes_raw ?loc (b: bytes) : expression = - location_wrap ?loc @@ E_literal (Literal_bytes b) + make_expr ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = - location_wrap ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) -let e_big_map ?loc lst : expression = location_wrap ?loc @@ E_big_map lst -let e_some ?loc s : expression = location_wrap ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} -let e_none ?loc () : expression = location_wrap ?loc @@ E_constant {cons_name = C_NONE; arguments = []} -let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} -let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} -let e_map ?loc lst : expression = location_wrap ?loc @@ E_map lst -let e_set ?loc lst : expression = location_wrap ?loc @@ E_set lst -let e_list ?loc lst : expression = location_wrap ?loc @@ E_list lst -let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor { constructor = Constructor s; element = a} -let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching {matchee=a;cases=b} + make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) +let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst +let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} +let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []} +let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} +let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} +let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst +let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst +let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst +let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} +let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; label= Label b} +let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b -let e_variable ?loc v = location_wrap ?loc @@ E_variable v -let e_skip ?loc () = location_wrap ?loc @@ E_skip +let e_variable ?loc v = make_expr ?loc @@ E_variable v +let e_skip ?loc () = make_expr ?loc @@ E_skip let e_let_in ?loc (binder, ascr) mut inline rhs let_result = - location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline } -let e_annotation ?loc anno_expr ty = location_wrap ?loc @@ E_ascription {anno_expr; type_annotation = ty} -let e_application ?loc a b = location_wrap ?loc @@ E_application {expr1=a ; expr2=b} -let e_binop ?loc name a b = location_wrap ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} -let e_constant ?loc name lst = location_wrap ?loc @@ E_constant {cons_name=name ; arguments = lst} -let e_look_up ?loc x y = location_wrap ?loc @@ E_look_up (x , y) + make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline } +let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_application ?loc a b = make_expr ?loc @@ E_application {expr1=a ; expr2=b} +let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} +let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} +let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) let e_sequence ?loc expr1 expr2 = e_let_in ?loc (Var.fresh (), Some t_unit) false false expr1 expr2 let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) (* @@ -141,14 +141,14 @@ let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) = e_matching ?loc a (ez_match_variant lst) let e_record_ez ?loc (lst : (string * expr) list) : expression = let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in - location_wrap ?loc @@ E_record map + make_expr ?loc @@ E_record map let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst let e_update ?loc record path update = let path = Label path in - location_wrap ?loc @@ E_record_update {record; path; update} + make_expr ?loc @@ E_record_update {record; path; update} let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) let e_pair ?loc a b : expression = e_tuple ?loc [a;b] @@ -177,13 +177,13 @@ let e_lambda ?loc (binder : expression_variable) (output_type : type_expression option) (result : expression) : expression = - location_wrap ?loc @@ E_lambda { - binder = binder; + make_expr ?loc @@ E_lambda { + binder = binder ; input_type = input_type ; output_type = output_type ; result ; } -let e_recursive ?loc fun_name fun_type lambda = location_wrap ?loc @@ E_recursive {fun_name; fun_type; lambda} +let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} let e_assign_with_let ?loc var access_path expr = diff --git a/src/stages/ast_simplified/combinators.mli b/src/stages/1-ast_imperative/combinators.mli similarity index 98% rename from src/stages/ast_simplified/combinators.mli rename to src/stages/1-ast_imperative/combinators.mli index 5dc0af74c..ca2f2d552 100644 --- a/src/stages/ast_simplified/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -46,6 +46,7 @@ val t_map : type_expression -> type_expression -> type_expression val t_operator : type_operator -> type_expression list -> type_expression result val t_set : type_expression -> type_expression +val make_expr : ?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 diff --git a/src/stages/1-ast_imperative/dune b/src/stages/1-ast_imperative/dune new file mode 100644 index 000000000..8966ca542 --- /dev/null +++ b/src/stages/1-ast_imperative/dune @@ -0,0 +1,13 @@ +(library + (name ast_imperative) + (public_name ligo.ast_impretative) + (libraries + simple-utils + tezos-utils + stage_common + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -open Simple_utils )) +) diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/1-ast_imperative/misc.ml similarity index 100% rename from src/stages/ast_simplified/misc.ml rename to src/stages/1-ast_imperative/misc.ml diff --git a/src/stages/ast_simplified/misc.mli b/src/stages/1-ast_imperative/misc.mli similarity index 100% rename from src/stages/ast_simplified/misc.mli rename to src/stages/1-ast_imperative/misc.mli diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml new file mode 100644 index 000000000..75d17207f --- /dev/null +++ b/src/stages/1-ast_imperative/types.ml @@ -0,0 +1,118 @@ +[@@@warning "-30"] + +module Location = Simple_utils.Location + +module Ast_imperative_parameter = struct + type type_meta = unit +end + +include Stage_common.Types + +(*include Ast_generic_type(Ast_simplified_parameter) +*) +include Ast_generic_type (Ast_imperative_parameter) + +type inline = bool +type program = declaration Location.wrap list +and declaration = + | Declaration_type of (type_variable * type_expression) + + (* A Declaration_constant is described by + * a name + * an optional type annotation + * a boolean indicating whether it should be inlined + * an expression *) + | Declaration_constant of (expression_variable * type_expression option * inline * expression) + +(* | Macro_declaration of macro_declaration *) +and expression = {expression_content: expression_content; location: Location.t} + +and expression_content = + (* Base *) + | E_literal of literal + | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *) + | E_variable of expression_variable + | E_application of application + | E_lambda of lambda + | E_recursive of recursive + | E_let_in of let_in + | E_skip + (* Variant *) + | E_constructor of constructor (* For user defined constructors *) + | E_matching of matching + (* Record *) + | E_record of expression label_map + | E_record_accessor of accessor + | E_record_update of update + (* Data Structures *) + (* TODO : move to constant*) + | E_map of (expression * expression) list (*move to operator *) + | E_big_map of (expression * expression) list (*move to operator *) + | E_list of expression list + | E_set of expression list + | E_look_up of (expression * expression) + (* Advanced *) + | E_ascription of ascription + +and constant = + { cons_name: constant' (* this is at the end because it is huge *) + ; arguments: expression list } + +and application = {expr1: expression; expr2: expression} + +and lambda = + { binder: expression_variable + ; input_type: type_expression option + ; output_type: type_expression option + ; result: expression } + +and recursive = { + fun_name : expression_variable; + fun_type : type_expression; + lambda : lambda; +} + +and let_in = + { let_binder: expression_variable * type_expression option + ; mut: bool + ; rhs: expression + ; let_result: expression + ; inline: bool } + +and constructor = {constructor: constructor'; element: expression} + +and accessor = {expr: expression; label: label} + +and update = {record: expression; path: label ; update: expression} + +and matching_expr = (expr,unit) matching_content +and matching = + { matchee: expression + ; cases: matching_expr + } + +and ascription = {anno_expr: expression; type_annotation: type_expression} + +and environment_element_definition = + | ED_binder + | ED_declaration of (expression * free_variables) + +and free_variables = expression_variable list + +and environment_element = + { type_value: type_expression + ; source_environment: full_environment + ; definition: environment_element_definition } + +and environment = (expression_variable * environment_element) list + +and type_environment = (type_variable * type_expression) list + +(* SUBST ??? *) +and small_environment = environment * type_environment + +and full_environment = small_environment List.Ne.t + +and expr = expression + +and texpr = type_expression diff --git a/src/stages/2-ast_complex/PP.ml b/src/stages/2-ast_complex/PP.ml new file mode 100644 index 000000000..d6e949751 --- /dev/null +++ b/src/stages/2-ast_complex/PP.ml @@ -0,0 +1,138 @@ +[@@@coverage exclude_file] +open Types +open Format +open PP_helpers + +include Stage_common.PP +include Ast_PP_type(Ast_complex_parameter) + +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 +and expression_content ppf (ec : expression_content) = + match ec with + | E_literal l -> + literal ppf l + | E_variable n -> + fprintf ppf "%a" expression_variable n + | E_application app -> + fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2 + | E_constructor c -> + fprintf ppf "%a(%a)" constructor c.constructor expression c.element + | E_constant c -> + fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) + c.arguments + | E_record m -> + fprintf ppf "%a" (tuple_or_record_sep_expr expression) m + | E_record_accessor ra -> + fprintf ppf "%a.%a" expression ra.expr label ra.label + | E_record_update {record; path; update} -> + fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + | E_map m -> + fprintf ppf "map[%a]" (list_sep_d assoc_expression) m + | E_big_map m -> + fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m + | E_list lst -> + fprintf ppf "list[%a]" (list_sep_d expression) lst + | E_set lst -> + fprintf ppf "set[%a]" (list_sep_d expression) lst + | E_look_up (ds, ind) -> + fprintf ppf "(%a)[%a]" expression ds expression ind + | E_lambda {binder; input_type; output_type; result} -> + fprintf ppf "lambda (%a:%a) : %a return %a" + expression_variable binder + (PP_helpers.option type_expression) + input_type + (PP_helpers.option type_expression) + output_type expression result + | E_recursive { fun_name; fun_type; lambda} -> + fprintf ppf "rec (%a:%a => %a )" + expression_variable fun_name + type_expression fun_type + expression_content (E_lambda lambda) + | E_matching {matchee; cases; _} -> + fprintf ppf "match %a with %a" expression matchee (matching expression) + cases + | E_let_in { let_binder ; rhs ; let_result; inline } -> + fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result + | E_skip -> + fprintf ppf "skip" + | E_ascription {anno_expr; type_annotation} -> + fprintf ppf "%a : %a" expression anno_expr type_expression + type_annotation + +and option_type_name ppf + ((n, ty_opt) : expression_variable * type_expression option) = + match ty_opt with + | None -> + fprintf ppf "%a" expression_variable n + | Some ty -> + fprintf ppf "%a : %a" expression_variable n type_expression ty + +and assoc_expression ppf : expr * expr -> unit = + fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b + +and single_record_patch ppf ((p, expr) : label * expr) = + fprintf ppf "%a <- %a" label p expression expr + +and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = + fun f ppf ((c,n),a) -> + fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a + +and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = + fun f ppf m -> match m with + | Match_tuple ((lst, b), _) -> + fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b + | Match_variant (lst, _) -> + fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst + | Match_bool {match_true ; match_false} -> + fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false + | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> + fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons + | Match_option {match_none ; match_some = (some, match_some, _)} -> + fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some + +(* Shows the type expected for the matched value *) +and matching_type ppf m = match m with + | Match_tuple _ -> + fprintf ppf "tuple" + | Match_variant (lst, _) -> + fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst + | Match_bool _ -> + fprintf ppf "boolean" + | Match_list _ -> + fprintf ppf "list" + | Match_option _ -> + fprintf ppf "option" + +and matching_variant_case_type ppf ((c,n),_a) = + fprintf ppf "| %a %a" constructor c expression_variable n + +and option_mut ppf mut = + if mut then + fprintf ppf "[@mut]" + else + fprintf ppf "" + +and option_inline ppf inline = + if inline then + fprintf ppf "[@inline]" + else + fprintf ppf "" + +let declaration ppf (d : declaration) = + match d with + | Declaration_type (type_name, te) -> + fprintf ppf "type %a = %a" type_variable type_name type_expression te + | Declaration_constant (name, ty_opt, i, expr) -> + fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression + expr + option_inline i + +let program ppf (p : program) = + fprintf ppf "@[%a@]" + (list_sep declaration (tag "@;")) + (List.map Location.unwrap p) diff --git a/src/stages/2-ast_complex/ast_complex.ml b/src/stages/2-ast_complex/ast_complex.ml new file mode 100644 index 000000000..e9614490a --- /dev/null +++ b/src/stages/2-ast_complex/ast_complex.ml @@ -0,0 +1,8 @@ +include Types + +(* include Misc *) +include Combinators +module Types = Types +module Misc = Misc +module PP=PP +module Combinators = Combinators diff --git a/src/stages/2-ast_complex/combinators.ml b/src/stages/2-ast_complex/combinators.ml new file mode 100644 index 000000000..9ac673a3c --- /dev/null +++ b/src/stages/2-ast_complex/combinators.ml @@ -0,0 +1,268 @@ +open Types +open Simple_utils.Trace +module Option = Simple_utils.Option + +module SMap = Map.String + +module Errors = struct + let bad_kind expected location = + let title () = Format.asprintf "a %s was expected" expected in + let message () = "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title message + let bad_type_operator type_op = + let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in + let message () = "" in + error title message +end +open Errors + +let make_t type_content = {type_content; type_meta = ()} + + +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 : type_expression = make_t @@ T_constant (TC_bool) +let t_string : type_expression = make_t @@ T_constant (TC_string) +let t_bytes : type_expression = make_t @@ T_constant (TC_bytes) +let t_int : type_expression = make_t @@ T_constant (TC_int) +let t_operation : type_expression = make_t @@ T_constant (TC_operation) +let t_nat : type_expression = make_t @@ T_constant (TC_nat) +let t_tez : type_expression = make_t @@ T_constant (TC_mutez) +let t_unit : type_expression = make_t @@ T_constant (TC_unit) +let t_address : type_expression = make_t @@ T_constant (TC_address) +let t_signature : type_expression = make_t @@ T_constant (TC_signature) +let t_key : type_expression = make_t @@ T_constant (TC_key) +let t_key_hash : type_expression = make_t @@ T_constant (TC_key_hash) +let t_timestamp : type_expression = make_t @@ T_constant (TC_timestamp) +let t_option o : type_expression = make_t @@ T_operator (TC_option o) +let t_list t : type_expression = make_t @@ T_operator (TC_list t) +let t_variable n : type_expression = make_t @@ T_variable (Var.of_name n) +let t_record_ez lst = + let lst = List.map (fun (k, v) -> (Label k, v)) lst in + let m = LMap.of_list lst in + make_t @@ T_record m +let t_record m : type_expression = + let lst = Map.String.to_kv_list m in + t_record_ez lst + +let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)] +let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst) + +let ez_t_sum (lst:(string * type_expression) 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 @@ T_sum map +let t_sum m : type_expression = + let lst = Map.String.to_kv_list m in + ez_t_sum lst + +let t_function type1 type2 : type_expression = make_t @@ T_arrow {type1; type2} +let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value)) +let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value)) +let t_set key : type_expression = make_t @@ T_operator (TC_set key) +let t_contract contract : type_expression = make_t @@ T_operator (TC_contract contract) + +(* TODO find a better way than using list*) +let t_operator op lst: type_expression result = + match op,lst with + | TC_set _ , [t] -> ok @@ t_set t + | TC_list _ , [t] -> ok @@ t_list t + | TC_option _ , [t] -> ok @@ t_option t + | TC_map (_,_) , [kt;vt] -> ok @@ t_map kt vt + | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map kt vt + | TC_contract _ , [t] -> ok @@ t_contract t + | _ , _ -> fail @@ bad_type_operator op + +let make_expr ?(loc = Location.generated) expression_content = + let location = loc in + { expression_content; location } + +let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n) +let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l +let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit) +let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n) +let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n) +let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n) +let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b) +let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s) +let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s) +let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s) +let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s) +let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s) +let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s) +let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s) +let e'_bytes b : expression_content result = + let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in + ok @@ E_literal (Literal_bytes bytes) +let e_bytes_hex ?loc b : expression result = + let%bind e' = e'_bytes b in + ok @@ make_expr ?loc e' +let e_bytes_raw ?loc (b: bytes) : expression = + make_expr ?loc @@ E_literal (Literal_bytes b) +let e_bytes_string ?loc (s: string) : expression = + make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) +let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst +let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} +let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []} +let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} +let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} +let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst +let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst +let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst +let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} +let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} +let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) +let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} +let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b +let e_variable ?loc v = make_expr ?loc @@ E_variable v +let e_skip ?loc () = make_expr ?loc @@ E_skip +let e_let_in ?loc (binder, ascr) inline rhs let_result = + make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline } +let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_application ?loc a b = make_expr ?loc @@ E_application {expr1=a ; expr2=b} +let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} +let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} +let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) +let e_sequence ?loc expr1 expr2 = e_let_in ?loc (Var.fresh (), Some t_unit) false expr1 expr2 +let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) +(* +let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) +*) +let ez_match_variant (lst : ((string * string) * 'a) list) = + let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in + Match_variant (lst,()) +let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) = + e_matching ?loc a (ez_match_variant lst) +let e_record_ez ?loc (lst : (string * expr) list) : expression = + let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in + make_expr ?loc @@ E_record map +let e_record ?loc map = + let lst = Map.String.to_kv_list map in + e_record_ez ?loc lst + +let e_update ?loc record path update = + let path = Label path in + make_expr ?loc @@ E_record_update {record; path; update} + +let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) +let e_pair ?loc a b : expression = e_tuple ?loc [a;b] + +let make_option_typed ?loc e t_opt = + match t_opt with + | None -> e + | Some t -> e_annotation ?loc e t + + +let e_typed_none ?loc t_opt = + let type_annotation = t_option t_opt in + e_annotation ?loc (e_none ?loc ()) type_annotation + +let e_typed_list ?loc lst t = + e_annotation ?loc (e_list lst) (t_list t) + +let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) +let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v) + +let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) + + +let e_lambda ?loc (binder : expression_variable) + (input_type : type_expression option) + (output_type : type_expression option) + (result : expression) + : expression = + make_expr ?loc @@ E_lambda { + binder = binder ; + input_type = input_type ; + output_type = output_type ; + result ; + } +let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} + + +let e_assign_with_let ?loc var access_path expr = + let var = Var.of_name (var) in + match access_path with + | [] -> (var, None), true, expr, false + + | lst -> + let rec aux path record= match path with + | [] -> failwith "acces_path cannot be empty" + | [e] -> e_update ?loc record e expr + | elem::tail -> + let next_record = e_accessor record elem in + e_update ?loc record elem (aux tail next_record ) + in + (var, None), true, (aux lst (e_variable var)), false + +let get_e_accessor = fun t -> + match t with + | E_record_accessor {expr; label} -> ok (expr , label) + | _ -> simple_fail "not an accessor" + +let assert_e_accessor = fun t -> + let%bind _ = get_e_accessor t in + ok () + +let get_e_pair = fun t -> + match t with + | E_record r -> ( + let lst = LMap.to_kv_list r in + match lst with + | [(Label "O",a);(Label "1",b)] + | [(Label "1",b);(Label "0",a)] -> + ok (a , b) + | _ -> simple_fail "not a pair" + ) + | _ -> simple_fail "not a pair" + +let get_e_list = fun t -> + match t with + | E_list lst -> ok lst + | _ -> simple_fail "not a list" + +let tuple_of_record (m: _ LMap.t) = + let aux i = + let opt = LMap.find_opt (Label (string_of_int i)) m in + Option.bind (fun opt -> Some (opt,i+1)) opt + in + Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux + +let get_e_tuple = fun t -> + match t with + | E_record r -> ok @@ tuple_of_record r + | _ -> simple_fail "ast_simplified: get_e_tuple: not a tuple" + +(* Same as get_e_pair *) +let extract_pair : expression -> (expression * expression) result = fun e -> + match e.expression_content with + | E_record r -> ( + let lst = LMap.to_kv_list r in + match lst with + | [(Label "O",a);(Label "1",b)] + | [(Label "1",b);(Label "0",a)] -> + ok (a , b) + | _ -> fail @@ bad_kind "pair" e.location + ) + | _ -> fail @@ bad_kind "pair" e.location + +let extract_list : expression -> (expression list) result = fun e -> + match e.expression_content with + | E_list lst -> ok lst + | _ -> fail @@ bad_kind "list" e.location + +let extract_record : expression -> (label * expression) list result = fun e -> + match e.expression_content with + | E_record lst -> ok @@ LMap.to_kv_list lst + | _ -> fail @@ bad_kind "record" e.location + +let extract_map : expression -> (expression * expression) list result = fun e -> + match e.expression_content with + | E_map lst -> ok lst + | _ -> fail @@ bad_kind "map" e.location diff --git a/src/stages/2-ast_complex/combinators.mli b/src/stages/2-ast_complex/combinators.mli new file mode 100644 index 000000000..e9d3dd144 --- /dev/null +++ b/src/stages/2-ast_complex/combinators.mli @@ -0,0 +1,135 @@ +open Types +open Simple_utils.Trace +(* +module Option = Simple_utils.Option + +module SMap = Map.String + +module Errors : sig + val bad_kind : name -> Location.t -> unit -> error +end +*) +val make_t : type_content -> type_expression +val t_bool : type_expression +val t_string : type_expression +val t_bytes : type_expression +val t_int : type_expression +val t_operation : type_expression +val t_nat : type_expression +val t_tez : type_expression +val t_unit : type_expression +val t_address : type_expression +val t_key : type_expression +val t_key_hash : type_expression +val t_timestamp : type_expression +val t_signature : type_expression +(* +val t_option : type_expression -> type_expression +*) +val t_list : type_expression -> type_expression +val t_variable : string -> type_expression +(* +val t_record : te_map -> type_expression +*) +val t_pair : ( type_expression * type_expression ) -> type_expression +val t_tuple : type_expression list -> type_expression + +val t_record : type_expression Map.String.t -> type_expression +val t_record_ez : (string * type_expression) list -> type_expression + +val t_sum : type_expression Map.String.t -> type_expression +val ez_t_sum : ( string * type_expression ) list -> type_expression + +val t_function : type_expression -> type_expression -> type_expression +val t_map : type_expression -> type_expression -> type_expression + +val t_operator : type_operator -> type_expression list -> type_expression result +val t_set : type_expression -> type_expression + +val make_expr : ?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 -> int -> expression +val e_nat : ?loc:Location.t -> int -> expression +val e_timestamp : ?loc:Location.t -> int -> expression +val e_bool : ?loc:Location.t -> bool -> expression +val e_string : ?loc:Location.t -> 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 -> int -> expression +val e'_bytes : string -> expression_content result +val e_bytes_hex : ?loc:Location.t -> string -> expression result +val e_bytes_raw : ?loc:Location.t -> bytes -> expression +val e_bytes_string : ?loc:Location.t -> string -> expression +val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression + +val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression +val e_tuple : ?loc:Location.t -> expression list -> 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_map : ?loc:Location.t -> ( expression * expression ) list -> expression +val e_set : ?loc:Location.t -> expression list -> expression +val e_list : ?loc:Location.t -> expression list -> expression +val e_pair : ?loc:Location.t -> expression -> expression -> expression +val e_constructor : ?loc:Location.t -> string -> expression -> expression +val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression +val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression +val e_accessor : ?loc:Location.t -> expression -> string -> expression +val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression +val e_variable : ?loc:Location.t -> expression_variable -> expression +val e_skip : ?loc:Location.t -> unit -> expression +val e_sequence : ?loc:Location.t -> expression -> expression -> expression +val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression +val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression +val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression +val e_application : ?loc:Location.t -> expression -> expression -> expression +val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression +val e_constant : ?loc:Location.t -> constant' -> expression list -> expression +val e_look_up : ?loc:Location.t -> expression -> expression -> expression +val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content +val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression + +val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression + +val e_typed_none : ?loc:Location.t -> type_expression -> expression + +val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression + +val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression +val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression + +val e_typed_set : ?loc:Location.t -> expression list -> 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 Map.String.t -> expression +val e_update : ?loc:Location.t -> expression -> string -> expression -> expression +val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) + +(* +val get_e_accessor : expression' -> ( expression * access_path ) result +*) + +val assert_e_accessor : expression_content -> unit result + +val get_e_pair : expression_content -> ( expression * expression ) result + +val get_e_list : expression_content -> ( expression list ) result +val get_e_tuple : expression_content -> ( expression list ) result +(* +val get_e_failwith : expression -> expression result +val is_e_failwith : expression -> bool +*) +val extract_pair : expression -> ( expression * expression ) result + +val extract_list : expression -> (expression list) result + +val extract_record : expression -> (label * expression) list result + +val extract_map : expression -> (expression * expression) list result diff --git a/src/stages/2-ast_complex/dune b/src/stages/2-ast_complex/dune new file mode 100644 index 000000000..4e1dac4af --- /dev/null +++ b/src/stages/2-ast_complex/dune @@ -0,0 +1,13 @@ +(library + (name ast_complex) + (public_name ligo.ast_complex) + (libraries + simple-utils + tezos-utils + stage_common + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -open Simple_utils )) +) diff --git a/src/stages/2-ast_complex/misc.ml b/src/stages/2-ast_complex/misc.ml new file mode 100644 index 000000000..f2094d3ca --- /dev/null +++ b/src/stages/2-ast_complex/misc.ml @@ -0,0 +1,331 @@ +open Trace +open Types + +open Stage_common.Helpers +module Errors = struct + let different_literals_because_different_types name a b () = + let title () = "literals have different types: " ^ name in + let message () = "" in + let data = [ + ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; + ("b" , fun () -> Format.asprintf "%a" PP.literal b ) + ] in + error ~data title message () + + let different_literals name a b () = + let title () = name ^ " are different" in + let message () = "" in + let data = [ + ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; + ("b" , fun () -> Format.asprintf "%a" PP.literal b ) + ] in + error ~data title message () + + let error_uncomparable_literals name a b () = + let title () = name ^ " are not comparable" in + let message () = "" in + let data = [ + ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; + ("b" , fun () -> Format.asprintf "%a" PP.literal b ) + ] in + error ~data title message () +end +open Errors + +let assert_literal_eq (a, b : literal * literal) : unit result = + match (a, b) with + | Literal_bool a, Literal_bool b when a = b -> ok () + | Literal_bool _, Literal_bool _ -> fail @@ different_literals "different bools" a b + | Literal_bool _, _ -> fail @@ different_literals_because_different_types "bool vs non-bool" a b + | 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 bytess" 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_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 + | 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 + +let rec assert_value_eq (a, b: (expression * expression )) : unit result = + Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b; + let error_content () = + Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b + in + trace (fun () -> error (thunk "not equal") error_content ()) @@ + match (a.expression_content , b.expression_content) with + | E_literal a , E_literal b -> + assert_literal_eq (a, b) + | E_literal _ , _ -> + simple_fail "comparing a literal with not a literal" + | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> ( + let%bind lst = + generic_try (simple_error "constants with different number of elements") + (fun () -> List.combine ca.arguments cb.arguments) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_constant _ , E_constant _ -> + simple_fail "different constants" + | E_constant _ , _ -> + let error_content () = + Format.asprintf "%a vs %a" + PP.expression a + PP.expression b + in + fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ()) + + | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> ( + let%bind _eq = assert_value_eq (ca.element, cb.element) in + ok () + ) + | E_constructor _, E_constructor _ -> + simple_fail "different constructors" + | E_constructor _, _ -> + simple_fail "comparing constructor with other expression" + + + | E_record sma, E_record smb -> ( + let aux _ a b = + match a, b with + | Some a, Some b -> Some (assert_value_eq (a, b)) + | _ -> Some (simple_fail "different record keys") + in + let%bind _all = bind_lmap @@ LMap.merge aux sma smb in + ok () + ) + | E_record _, _ -> + simple_fail "comparing record with other expression" + + | E_record_update ura, E_record_update urb -> + let _ = + generic_try (simple_error "Updating different record") @@ + fun () -> assert_value_eq (ura.record, urb.record) in + let aux (Label a,Label b) = + assert (String.equal a b) + in + let () = aux (ura.path, urb.path) in + let%bind () = assert_value_eq (ura.update,urb.update) in + ok () + | E_record_update _, _ -> + simple_fail "comparing record update with other expression" + + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( + let%bind lst = generic_try (simple_error "maps of different lengths") + (fun () -> + let lsta' = List.sort compare lsta in + let lstb' = List.sort compare lstb in + List.combine lsta' lstb') in + let aux = fun ((ka, va), (kb, vb)) -> + let%bind _ = assert_value_eq (ka, kb) in + let%bind _ = assert_value_eq (va, vb) in + ok () in + let%bind _all = bind_map_list aux lst in + ok () + ) + | (E_map _ | E_big_map _), _ -> + simple_fail "comparing map with other expression" + + | E_list lsta, E_list lstb -> ( + let%bind lst = + generic_try (simple_error "list of different lengths") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_map_list assert_value_eq lst in + ok () + ) + | E_list _, _ -> + simple_fail "comparing list with other expression" + + | E_set lsta, E_set lstb -> ( + let lsta' = List.sort (compare) lsta in + let lstb' = List.sort (compare) lstb in + let%bind lst = + generic_try (simple_error "set of different lengths") + (fun () -> List.combine lsta' lstb') in + let%bind _all = bind_map_list assert_value_eq lst in + ok () + ) + | E_set _, _ -> + simple_fail "comparing set with other expression" + + | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b) + | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) + | (E_variable _, _) | (E_lambda _, _) + | (E_application _, _) | (E_let_in _, _) + | (E_recursive _,_) | (E_record_accessor _, _) + | (E_look_up _, _) | (E_matching _, _) + | (E_skip, _) -> simple_fail "comparing not a value" + +let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) + +(* module Rename = struct + * open Trace + * + * module Type = struct + * (\* Type renaming, not needed. Yet. *\) + * end + * + * module Value = struct + * type renaming = string * (string * access_path) (\* src -> dst *\) + * type renamings = renaming list + * let filter (r:renamings) (s:string) : renamings = + * List.filter (fun (x, _) -> not (x = s)) r + * let filters (r:renamings) (ss:string list) : renamings = + * List.filter (fun (x, _) -> not (List.mem x ss)) r + * + * let rec rename_instruction (r:renamings) (i:instruction) : instruction result = + * match i with + * | I_assignment ({name;annotated_expression = e} as a) -> ( + * match List.assoc_opt name r with + * | None -> + * let%bind annotated_expression = rename_annotated_expression (filter r name) e in + * ok (I_assignment {a with annotated_expression}) + * | Some (name', lst) -> ( + * let%bind annotated_expression = rename_annotated_expression r e in + * match lst with + * | [] -> ok (I_assignment {name = name' ; annotated_expression}) + * | lst -> + * let (hds, tl) = + * let open List in + * let r = rev lst in + * rev @@ tl r, hd r + * in + * let%bind tl' = match tl with + * | Access_record n -> ok n + * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in + * ok (I_record_patch (name', hds, [tl', annotated_expression])) + * ) + * ) + * | I_skip -> ok I_skip + * | I_fail e -> + * let%bind e' = rename_annotated_expression r e in + * ok (I_fail e') + * | I_loop (cond, body) -> + * let%bind cond' = rename_annotated_expression r cond in + * let%bind body' = rename_block r body in + * ok (I_loop (cond', body')) + * | I_matching (ae, m) -> + * let%bind ae' = rename_annotated_expression r ae in + * let%bind m' = rename_matching rename_block r m in + * ok (I_matching (ae', m')) + * | I_record_patch (v, path, lst) -> + * let aux (x, y) = + * let%bind y' = rename_annotated_expression (filter r v) y in + * ok (x, y') in + * let%bind lst' = bind_map_list aux lst in + * match List.assoc_opt v r with + * | None -> ( + * ok (I_record_patch (v, path, lst')) + * ) + * | Some (v', path') -> ( + * ok (I_record_patch (v', path' @ path, lst')) + * ) + * and rename_block (r:renamings) (bl:block) : block result = + * bind_map_list (rename_instruction r) bl + * + * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = + * fun f r m -> + * match m with + * | Match_bool { match_true = mt ; match_false = mf } -> + * let%bind match_true = f r mt in + * let%bind match_false = f r mf in + * ok (Match_bool {match_true ; match_false}) + * | Match_option { match_none = mn ; match_some = (some, ms) } -> + * let%bind match_none = f r mn in + * let%bind ms' = f (filter r some) ms in + * ok (Match_option {match_none ; match_some = (some, ms')}) + * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> + * let%bind match_nil = f r mn in + * let%bind mc' = f (filters r [hd;tl]) mc in + * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) + * | Match_tuple (lst, body) -> + * let%bind body' = f (filters r lst) body in + * ok (Match_tuple (lst, body')) + * + * and rename_matching_instruction = fun x -> rename_matching rename_block x + * + * and rename_matching_expr = fun x -> rename_matching rename_expression x + * + * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = + * let%bind expression = rename_expression r ae.expression in + * ok {ae with expression} + * + * and rename_expression : renamings -> expression -> expression result = fun r e -> + * match e with + * | E_literal _ as l -> ok l + * | E_constant (name, lst) -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_constant (name, lst')) + * | E_constructor (name, ae) -> + * let%bind ae' = rename_annotated_expression r ae in + * ok (E_constructor (name, ae')) + * | E_variable v -> ( + * match List.assoc_opt v r with + * | None -> ok (E_variable v) + * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) + * ) + * | E_lambda ({binder;body;result} as l) -> + * let r' = filter r binder in + * let%bind body = rename_block r' body in + * let%bind result = rename_annotated_expression r' result in + * ok (E_lambda {l with body ; result}) + * | E_application (f, arg) -> + * let%bind f' = rename_annotated_expression r f in + * let%bind arg' = rename_annotated_expression r arg in + * ok (E_application (f', arg')) + * | E_tuple lst -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_tuple lst') + * | E_accessor (ae, p) -> + * let%bind ae' = rename_annotated_expression r ae in + * ok (E_accessor (ae', p)) + * | E_record sm -> + * let%bind sm' = bind_smap + * @@ SMap.map (rename_annotated_expression r) sm in + * ok (E_record sm') + * | E_map m -> + * let%bind m' = bind_map_list + * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in + * ok (E_map m') + * | E_list lst -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_list lst') + * | E_look_up m -> + * let%bind m' = bind_map_pair (rename_annotated_expression r) m in + * ok (E_look_up m') + * | E_matching (ae, m) -> + * let%bind ae' = rename_annotated_expression r ae in + * let%bind m' = rename_matching rename_annotated_expression r m in + * ok (E_matching (ae', m')) + * end + * end *) diff --git a/src/stages/2-ast_complex/misc.mli b/src/stages/2-ast_complex/misc.mli new file mode 100644 index 000000000..0784d109c --- /dev/null +++ b/src/stages/2-ast_complex/misc.mli @@ -0,0 +1,20 @@ +open Trace +open Types + + +(* + +module Errors : sig + val different_literals_because_different_types : name -> literal -> literal -> unit -> error + + val different_literals : name -> literal -> literal -> unit -> error + + val error_uncomparable_literals : name -> literal -> literal -> unit -> error +end + +val assert_literal_eq : ( literal * literal ) -> unit result +*) + +val assert_value_eq : ( expression * expression ) -> unit result + +val is_value_eq : ( expression * expression ) -> bool diff --git a/src/stages/2-ast_complex/types.ml b/src/stages/2-ast_complex/types.ml new file mode 100644 index 000000000..70a348975 --- /dev/null +++ b/src/stages/2-ast_complex/types.ml @@ -0,0 +1,117 @@ +[@@@warning "-30"] + +module Location = Simple_utils.Location + +module Ast_complex_parameter = struct + type type_meta = unit +end + +include Stage_common.Types + +(*include Ast_generic_type(Ast_simplified_parameter) +*) +include Ast_generic_type (Ast_complex_parameter) + +type inline = bool +type program = declaration Location.wrap list +and declaration = + | Declaration_type of (type_variable * type_expression) + + (* A Declaration_constant is described by + * a name + * an optional type annotation + * a boolean indicating whether it should be inlined + * an expression *) + | Declaration_constant of (expression_variable * type_expression option * inline * expression) + +(* | Macro_declaration of macro_declaration *) +and expression = {expression_content: expression_content; location: Location.t} + +and expression_content = + (* Base *) + | E_literal of literal + | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *) + | E_variable of expression_variable + | E_application of application + | E_lambda of lambda + | E_recursive of recursive + | E_let_in of let_in + | E_skip + (* Variant *) + | E_constructor of constructor (* For user defined constructors *) + | E_matching of matching + (* Record *) + | E_record of expression label_map + | E_record_accessor of accessor + | E_record_update of update + (* Data Structures *) + (* TODO : move to constant*) + | E_map of (expression * expression) list (*move to operator *) + | E_big_map of (expression * expression) list (*move to operator *) + | E_list of expression list + | E_set of expression list + | E_look_up of (expression * expression) + (* Advanced *) + | E_ascription of ascription + +and constant = + { cons_name: constant' (* this is at the end because it is huge *) + ; arguments: expression list } + +and application = {expr1: expression; expr2: expression} + +and lambda = + { binder: expression_variable + ; input_type: type_expression option + ; output_type: type_expression option + ; result: expression } + +and recursive = { + fun_name : expression_variable; + fun_type : type_expression; + lambda : lambda; +} + +and let_in = + { let_binder: expression_variable * type_expression option + ; rhs: expression + ; let_result: expression + ; inline: bool } + +and constructor = {constructor: constructor'; element: expression} + +and accessor = {expr: expression; label: label} + +and update = {record: expression; path: label ; update: expression} + +and matching_expr = (expr,unit) matching_content +and matching = + { matchee: expression + ; cases: matching_expr + } + +and ascription = {anno_expr: expression; type_annotation: type_expression} + +and environment_element_definition = + | ED_binder + | ED_declaration of (expression * free_variables) + +and free_variables = expression_variable list + +and environment_element = + { type_value: type_expression + ; source_environment: full_environment + ; definition: environment_element_definition } + +and environment = (expression_variable * environment_element) list + +and type_environment = (type_variable * type_expression) list + +(* SUBST ??? *) +and small_environment = environment * type_environment + +and full_environment = small_environment List.Ne.t + +and expr = expression + +and texpr = type_expression diff --git a/src/stages/3-ast_simplified/PP.ml b/src/stages/3-ast_simplified/PP.ml new file mode 100644 index 000000000..fa4404307 --- /dev/null +++ b/src/stages/3-ast_simplified/PP.ml @@ -0,0 +1,138 @@ +[@@@coverage exclude_file] +open Types +open Format +open PP_helpers + +include Stage_common.PP +include Ast_PP_type(Ast_simplified_parameter) + +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 +and expression_content ppf (ec : expression_content) = + match ec with + | E_literal l -> + literal ppf l + | E_variable n -> + fprintf ppf "%a" expression_variable n + | E_application app -> + fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2 + | E_constructor c -> + fprintf ppf "%a(%a)" constructor c.constructor expression c.element + | E_constant c -> + fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) + c.arguments + | E_record m -> + fprintf ppf "%a" (tuple_or_record_sep_expr expression) m + | E_record_accessor ra -> + fprintf ppf "%a.%a" expression ra.expr label ra.label + | E_record_update {record; path; update} -> + fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + | E_map m -> + fprintf ppf "map[%a]" (list_sep_d assoc_expression) m + | E_big_map m -> + fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m + | E_list lst -> + fprintf ppf "list[%a]" (list_sep_d expression) lst + | E_set lst -> + fprintf ppf "set[%a]" (list_sep_d expression) lst + | E_look_up (ds, ind) -> + fprintf ppf "(%a)[%a]" expression ds expression ind + | E_lambda {binder; input_type; output_type; result} -> + fprintf ppf "lambda (%a:%a) : %a return %a" + expression_variable binder + (PP_helpers.option type_expression) + input_type + (PP_helpers.option type_expression) + output_type expression result + | E_recursive { fun_name; fun_type; lambda} -> + fprintf ppf "rec (%a:%a => %a )" + expression_variable fun_name + type_expression fun_type + expression_content (E_lambda lambda) + | E_matching {matchee; cases; _} -> + fprintf ppf "match %a with %a" expression matchee (matching expression) + cases + | E_let_in { let_binder ;rhs ; let_result; inline } -> + fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result + | E_skip -> + fprintf ppf "skip" + | E_ascription {anno_expr; type_annotation} -> + fprintf ppf "%a : %a" expression anno_expr type_expression + type_annotation + +and option_type_name ppf + ((n, ty_opt) : expression_variable * type_expression option) = + match ty_opt with + | None -> + fprintf ppf "%a" expression_variable n + | Some ty -> + fprintf ppf "%a : %a" expression_variable n type_expression ty + +and assoc_expression ppf : expr * expr -> unit = + fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b + +and single_record_patch ppf ((p, expr) : label * expr) = + fprintf ppf "%a <- %a" label p expression expr + +and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = + fun f ppf ((c,n),a) -> + fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a + +and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = + fun f ppf m -> match m with + | Match_tuple ((lst, b), _) -> + fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b + | Match_variant (lst, _) -> + fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst + | Match_bool {match_true ; match_false} -> + fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false + | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> + fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons + | Match_option {match_none ; match_some = (some, match_some, _)} -> + fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some + +(* Shows the type expected for the matched value *) +and matching_type ppf m = match m with + | Match_tuple _ -> + fprintf ppf "tuple" + | Match_variant (lst, _) -> + fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst + | Match_bool _ -> + fprintf ppf "boolean" + | Match_list _ -> + fprintf ppf "list" + | Match_option _ -> + fprintf ppf "option" + +and matching_variant_case_type ppf ((c,n),_a) = + fprintf ppf "| %a %a" constructor c expression_variable n + +and option_mut ppf mut = + if mut then + fprintf ppf "[@mut]" + else + fprintf ppf "" + +and option_inline ppf inline = + if inline then + fprintf ppf "[@inline]" + else + fprintf ppf "" + +let declaration ppf (d : declaration) = + match d with + | Declaration_type (type_name, te) -> + fprintf ppf "type %a = %a" type_variable type_name type_expression te + | Declaration_constant (name, ty_opt, i, expr) -> + fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression + expr + option_inline i + +let program ppf (p : program) = + fprintf ppf "@[%a@]" + (list_sep declaration (tag "@;")) + (List.map Location.unwrap p) diff --git a/src/stages/3-ast_simplified/ast_simplified.ml b/src/stages/3-ast_simplified/ast_simplified.ml new file mode 100644 index 000000000..e9614490a --- /dev/null +++ b/src/stages/3-ast_simplified/ast_simplified.ml @@ -0,0 +1,8 @@ +include Types + +(* include Misc *) +include Combinators +module Types = Types +module Misc = Misc +module PP=PP +module Combinators = Combinators diff --git a/src/stages/3-ast_simplified/combinators.ml b/src/stages/3-ast_simplified/combinators.ml new file mode 100644 index 000000000..2a5e60aff --- /dev/null +++ b/src/stages/3-ast_simplified/combinators.ml @@ -0,0 +1,268 @@ +open Types +open Simple_utils.Trace +module Option = Simple_utils.Option + +module SMap = Map.String + +module Errors = struct + let bad_kind expected location = + let title () = Format.asprintf "a %s was expected" expected in + let message () = "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title message + let bad_type_operator type_op = + let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in + let message () = "" in + error title message +end +open Errors + +let make_t type_content = {type_content; type_meta = ()} + + +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 : type_expression = make_t @@ T_constant (TC_bool) +let t_string : type_expression = make_t @@ T_constant (TC_string) +let t_bytes : type_expression = make_t @@ T_constant (TC_bytes) +let t_int : type_expression = make_t @@ T_constant (TC_int) +let t_operation : type_expression = make_t @@ T_constant (TC_operation) +let t_nat : type_expression = make_t @@ T_constant (TC_nat) +let t_tez : type_expression = make_t @@ T_constant (TC_mutez) +let t_unit : type_expression = make_t @@ T_constant (TC_unit) +let t_address : type_expression = make_t @@ T_constant (TC_address) +let t_signature : type_expression = make_t @@ T_constant (TC_signature) +let t_key : type_expression = make_t @@ T_constant (TC_key) +let t_key_hash : type_expression = make_t @@ T_constant (TC_key_hash) +let t_timestamp : type_expression = make_t @@ T_constant (TC_timestamp) +let t_option o : type_expression = make_t @@ T_operator (TC_option o) +let t_list t : type_expression = make_t @@ T_operator (TC_list t) +let t_variable n : type_expression = make_t @@ T_variable (Var.of_name n) +let t_record_ez lst = + let lst = List.map (fun (k, v) -> (Label k, v)) lst in + let m = LMap.of_list lst in + make_t @@ T_record m +let t_record m : type_expression = + let lst = Map.String.to_kv_list m in + t_record_ez lst + +let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)] +let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst) + +let ez_t_sum (lst:(string * type_expression) 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 @@ T_sum map +let t_sum m : type_expression = + let lst = Map.String.to_kv_list m in + ez_t_sum lst + +let t_function type1 type2 : type_expression = make_t @@ T_arrow {type1; type2} +let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value)) +let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value)) +let t_set key : type_expression = make_t @@ T_operator (TC_set key) +let t_contract contract : type_expression = make_t @@ T_operator (TC_contract contract) + +(* TODO find a better way than using list*) +let t_operator op lst: type_expression result = + match op,lst with + | TC_set _ , [t] -> ok @@ t_set t + | TC_list _ , [t] -> ok @@ t_list t + | TC_option _ , [t] -> ok @@ t_option t + | TC_map (_,_) , [kt;vt] -> ok @@ t_map kt vt + | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map kt vt + | TC_contract _ , [t] -> ok @@ t_contract t + | _ , _ -> fail @@ bad_type_operator op + +let make_expr ?(loc = Location.generated) expression_content = + let location = loc in + { expression_content; location } + +let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n) +let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l +let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit) +let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n) +let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n) +let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n) +let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b) +let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s) +let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s) +let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s) +let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s) +let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s) +let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s) +let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s) +let e'_bytes b : expression_content result = + let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in + ok @@ E_literal (Literal_bytes bytes) +let e_bytes_hex ?loc b : expression result = + let%bind e' = e'_bytes b in + ok @@ make_expr ?loc e' +let e_bytes_raw ?loc (b: bytes) : expression = + make_expr ?loc @@ E_literal (Literal_bytes b) +let e_bytes_string ?loc (s: string) : expression = + make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) +let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst +let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} +let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []} +let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} +let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} +let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst +let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst +let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst +let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} +let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} +let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) +let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} +let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b +let e_variable ?loc v = make_expr ?loc @@ E_variable v +let e_skip ?loc () = make_expr ?loc @@ E_skip +let e_let_in ?loc (binder, ascr) inline rhs let_result = + make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } +let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_application ?loc a b = make_expr ?loc @@ E_application {expr1=a ; expr2=b} +let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} +let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} +let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) +let e_sequence ?loc expr1 expr2 = e_let_in ?loc (Var.fresh (), Some t_unit) false expr1 expr2 +let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) +(* +let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) +*) +let ez_match_variant (lst : ((string * string) * 'a) list) = + let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in + Match_variant (lst,()) +let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) = + e_matching ?loc a (ez_match_variant lst) +let e_record_ez ?loc (lst : (string * expr) list) : expression = + let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in + make_expr ?loc @@ E_record map +let e_record ?loc map = + let lst = Map.String.to_kv_list map in + e_record_ez ?loc lst + +let e_update ?loc record path update = + let path = Label path in + make_expr ?loc @@ E_record_update {record; path; update} + +let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) +let e_pair ?loc a b : expression = e_tuple ?loc [a;b] + +let make_option_typed ?loc e t_opt = + match t_opt with + | None -> e + | Some t -> e_annotation ?loc e t + + +let e_typed_none ?loc t_opt = + let type_annotation = t_option t_opt in + e_annotation ?loc (e_none ?loc ()) type_annotation + +let e_typed_list ?loc lst t = + e_annotation ?loc (e_list lst) (t_list t) + +let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) +let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v) + +let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) + + +let e_lambda ?loc (binder : expression_variable) + (input_type : type_expression option) + (output_type : type_expression option) + (result : expression) + : expression = + make_expr ?loc @@ E_lambda { + binder = binder ; + input_type = input_type ; + output_type = output_type ; + result ; + } +let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} + + +let e_assign_with_let ?loc var access_path expr = + let var = Var.of_name (var) in + match access_path with + | [] -> (var, None), true, expr, false + + | lst -> + let rec aux path record= match path with + | [] -> failwith "acces_path cannot be empty" + | [e] -> e_update ?loc record e expr + | elem::tail -> + let next_record = e_accessor record elem in + e_update ?loc record elem (aux tail next_record ) + in + (var, None), true, (aux lst (e_variable var)), false + +let get_e_accessor = fun t -> + match t with + | E_record_accessor {expr; label} -> ok (expr , label) + | _ -> simple_fail "not an accessor" + +let assert_e_accessor = fun t -> + let%bind _ = get_e_accessor t in + ok () + +let get_e_pair = fun t -> + match t with + | E_record r -> ( + let lst = LMap.to_kv_list r in + match lst with + | [(Label "O",a);(Label "1",b)] + | [(Label "1",b);(Label "0",a)] -> + ok (a , b) + | _ -> simple_fail "not a pair" + ) + | _ -> simple_fail "not a pair" + +let get_e_list = fun t -> + match t with + | E_list lst -> ok lst + | _ -> simple_fail "not a list" + +let tuple_of_record (m: _ LMap.t) = + let aux i = + let opt = LMap.find_opt (Label (string_of_int i)) m in + Option.bind (fun opt -> Some (opt,i+1)) opt + in + Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux + +let get_e_tuple = fun t -> + match t with + | E_record r -> ok @@ tuple_of_record r + | _ -> simple_fail "ast_simplified: get_e_tuple: not a tuple" + +(* Same as get_e_pair *) +let extract_pair : expression -> (expression * expression) result = fun e -> + match e.expression_content with + | E_record r -> ( + let lst = LMap.to_kv_list r in + match lst with + | [(Label "O",a);(Label "1",b)] + | [(Label "1",b);(Label "0",a)] -> + ok (a , b) + | _ -> fail @@ bad_kind "pair" e.location + ) + | _ -> fail @@ bad_kind "pair" e.location + +let extract_list : expression -> (expression list) result = fun e -> + match e.expression_content with + | E_list lst -> ok lst + | _ -> fail @@ bad_kind "list" e.location + +let extract_record : expression -> (label * expression) list result = fun e -> + match e.expression_content with + | E_record lst -> ok @@ LMap.to_kv_list lst + | _ -> fail @@ bad_kind "record" e.location + +let extract_map : expression -> (expression * expression) list result = fun e -> + match e.expression_content with + | E_map lst -> ok lst + | _ -> fail @@ bad_kind "map" e.location diff --git a/src/stages/3-ast_simplified/combinators.mli b/src/stages/3-ast_simplified/combinators.mli new file mode 100644 index 000000000..e9d3dd144 --- /dev/null +++ b/src/stages/3-ast_simplified/combinators.mli @@ -0,0 +1,135 @@ +open Types +open Simple_utils.Trace +(* +module Option = Simple_utils.Option + +module SMap = Map.String + +module Errors : sig + val bad_kind : name -> Location.t -> unit -> error +end +*) +val make_t : type_content -> type_expression +val t_bool : type_expression +val t_string : type_expression +val t_bytes : type_expression +val t_int : type_expression +val t_operation : type_expression +val t_nat : type_expression +val t_tez : type_expression +val t_unit : type_expression +val t_address : type_expression +val t_key : type_expression +val t_key_hash : type_expression +val t_timestamp : type_expression +val t_signature : type_expression +(* +val t_option : type_expression -> type_expression +*) +val t_list : type_expression -> type_expression +val t_variable : string -> type_expression +(* +val t_record : te_map -> type_expression +*) +val t_pair : ( type_expression * type_expression ) -> type_expression +val t_tuple : type_expression list -> type_expression + +val t_record : type_expression Map.String.t -> type_expression +val t_record_ez : (string * type_expression) list -> type_expression + +val t_sum : type_expression Map.String.t -> type_expression +val ez_t_sum : ( string * type_expression ) list -> type_expression + +val t_function : type_expression -> type_expression -> type_expression +val t_map : type_expression -> type_expression -> type_expression + +val t_operator : type_operator -> type_expression list -> type_expression result +val t_set : type_expression -> type_expression + +val make_expr : ?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 -> int -> expression +val e_nat : ?loc:Location.t -> int -> expression +val e_timestamp : ?loc:Location.t -> int -> expression +val e_bool : ?loc:Location.t -> bool -> expression +val e_string : ?loc:Location.t -> 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 -> int -> expression +val e'_bytes : string -> expression_content result +val e_bytes_hex : ?loc:Location.t -> string -> expression result +val e_bytes_raw : ?loc:Location.t -> bytes -> expression +val e_bytes_string : ?loc:Location.t -> string -> expression +val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression + +val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression +val e_tuple : ?loc:Location.t -> expression list -> 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_map : ?loc:Location.t -> ( expression * expression ) list -> expression +val e_set : ?loc:Location.t -> expression list -> expression +val e_list : ?loc:Location.t -> expression list -> expression +val e_pair : ?loc:Location.t -> expression -> expression -> expression +val e_constructor : ?loc:Location.t -> string -> expression -> expression +val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression +val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression +val e_accessor : ?loc:Location.t -> expression -> string -> expression +val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression +val e_variable : ?loc:Location.t -> expression_variable -> expression +val e_skip : ?loc:Location.t -> unit -> expression +val e_sequence : ?loc:Location.t -> expression -> expression -> expression +val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression +val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression +val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression +val e_application : ?loc:Location.t -> expression -> expression -> expression +val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression +val e_constant : ?loc:Location.t -> constant' -> expression list -> expression +val e_look_up : ?loc:Location.t -> expression -> expression -> expression +val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content +val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression + +val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression + +val e_typed_none : ?loc:Location.t -> type_expression -> expression + +val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression + +val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression +val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression + +val e_typed_set : ?loc:Location.t -> expression list -> 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 Map.String.t -> expression +val e_update : ?loc:Location.t -> expression -> string -> expression -> expression +val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) + +(* +val get_e_accessor : expression' -> ( expression * access_path ) result +*) + +val assert_e_accessor : expression_content -> unit result + +val get_e_pair : expression_content -> ( expression * expression ) result + +val get_e_list : expression_content -> ( expression list ) result +val get_e_tuple : expression_content -> ( expression list ) result +(* +val get_e_failwith : expression -> expression result +val is_e_failwith : expression -> bool +*) +val extract_pair : expression -> ( expression * expression ) result + +val extract_list : expression -> (expression list) result + +val extract_record : expression -> (label * expression) list result + +val extract_map : expression -> (expression * expression) list result diff --git a/src/stages/ast_simplified/dune b/src/stages/3-ast_simplified/dune similarity index 100% rename from src/stages/ast_simplified/dune rename to src/stages/3-ast_simplified/dune diff --git a/src/stages/3-ast_simplified/misc.ml b/src/stages/3-ast_simplified/misc.ml new file mode 100644 index 000000000..f2094d3ca --- /dev/null +++ b/src/stages/3-ast_simplified/misc.ml @@ -0,0 +1,331 @@ +open Trace +open Types + +open Stage_common.Helpers +module Errors = struct + let different_literals_because_different_types name a b () = + let title () = "literals have different types: " ^ name in + let message () = "" in + let data = [ + ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; + ("b" , fun () -> Format.asprintf "%a" PP.literal b ) + ] in + error ~data title message () + + let different_literals name a b () = + let title () = name ^ " are different" in + let message () = "" in + let data = [ + ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; + ("b" , fun () -> Format.asprintf "%a" PP.literal b ) + ] in + error ~data title message () + + let error_uncomparable_literals name a b () = + let title () = name ^ " are not comparable" in + let message () = "" in + let data = [ + ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; + ("b" , fun () -> Format.asprintf "%a" PP.literal b ) + ] in + error ~data title message () +end +open Errors + +let assert_literal_eq (a, b : literal * literal) : unit result = + match (a, b) with + | Literal_bool a, Literal_bool b when a = b -> ok () + | Literal_bool _, Literal_bool _ -> fail @@ different_literals "different bools" a b + | Literal_bool _, _ -> fail @@ different_literals_because_different_types "bool vs non-bool" a b + | 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 bytess" 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_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 + | 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 + +let rec assert_value_eq (a, b: (expression * expression )) : unit result = + Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b; + let error_content () = + Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b + in + trace (fun () -> error (thunk "not equal") error_content ()) @@ + match (a.expression_content , b.expression_content) with + | E_literal a , E_literal b -> + assert_literal_eq (a, b) + | E_literal _ , _ -> + simple_fail "comparing a literal with not a literal" + | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> ( + let%bind lst = + generic_try (simple_error "constants with different number of elements") + (fun () -> List.combine ca.arguments cb.arguments) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_constant _ , E_constant _ -> + simple_fail "different constants" + | E_constant _ , _ -> + let error_content () = + Format.asprintf "%a vs %a" + PP.expression a + PP.expression b + in + fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ()) + + | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> ( + let%bind _eq = assert_value_eq (ca.element, cb.element) in + ok () + ) + | E_constructor _, E_constructor _ -> + simple_fail "different constructors" + | E_constructor _, _ -> + simple_fail "comparing constructor with other expression" + + + | E_record sma, E_record smb -> ( + let aux _ a b = + match a, b with + | Some a, Some b -> Some (assert_value_eq (a, b)) + | _ -> Some (simple_fail "different record keys") + in + let%bind _all = bind_lmap @@ LMap.merge aux sma smb in + ok () + ) + | E_record _, _ -> + simple_fail "comparing record with other expression" + + | E_record_update ura, E_record_update urb -> + let _ = + generic_try (simple_error "Updating different record") @@ + fun () -> assert_value_eq (ura.record, urb.record) in + let aux (Label a,Label b) = + assert (String.equal a b) + in + let () = aux (ura.path, urb.path) in + let%bind () = assert_value_eq (ura.update,urb.update) in + ok () + | E_record_update _, _ -> + simple_fail "comparing record update with other expression" + + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( + let%bind lst = generic_try (simple_error "maps of different lengths") + (fun () -> + let lsta' = List.sort compare lsta in + let lstb' = List.sort compare lstb in + List.combine lsta' lstb') in + let aux = fun ((ka, va), (kb, vb)) -> + let%bind _ = assert_value_eq (ka, kb) in + let%bind _ = assert_value_eq (va, vb) in + ok () in + let%bind _all = bind_map_list aux lst in + ok () + ) + | (E_map _ | E_big_map _), _ -> + simple_fail "comparing map with other expression" + + | E_list lsta, E_list lstb -> ( + let%bind lst = + generic_try (simple_error "list of different lengths") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_map_list assert_value_eq lst in + ok () + ) + | E_list _, _ -> + simple_fail "comparing list with other expression" + + | E_set lsta, E_set lstb -> ( + let lsta' = List.sort (compare) lsta in + let lstb' = List.sort (compare) lstb in + let%bind lst = + generic_try (simple_error "set of different lengths") + (fun () -> List.combine lsta' lstb') in + let%bind _all = bind_map_list assert_value_eq lst in + ok () + ) + | E_set _, _ -> + simple_fail "comparing set with other expression" + + | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b) + | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) + | (E_variable _, _) | (E_lambda _, _) + | (E_application _, _) | (E_let_in _, _) + | (E_recursive _,_) | (E_record_accessor _, _) + | (E_look_up _, _) | (E_matching _, _) + | (E_skip, _) -> simple_fail "comparing not a value" + +let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) + +(* module Rename = struct + * open Trace + * + * module Type = struct + * (\* Type renaming, not needed. Yet. *\) + * end + * + * module Value = struct + * type renaming = string * (string * access_path) (\* src -> dst *\) + * type renamings = renaming list + * let filter (r:renamings) (s:string) : renamings = + * List.filter (fun (x, _) -> not (x = s)) r + * let filters (r:renamings) (ss:string list) : renamings = + * List.filter (fun (x, _) -> not (List.mem x ss)) r + * + * let rec rename_instruction (r:renamings) (i:instruction) : instruction result = + * match i with + * | I_assignment ({name;annotated_expression = e} as a) -> ( + * match List.assoc_opt name r with + * | None -> + * let%bind annotated_expression = rename_annotated_expression (filter r name) e in + * ok (I_assignment {a with annotated_expression}) + * | Some (name', lst) -> ( + * let%bind annotated_expression = rename_annotated_expression r e in + * match lst with + * | [] -> ok (I_assignment {name = name' ; annotated_expression}) + * | lst -> + * let (hds, tl) = + * let open List in + * let r = rev lst in + * rev @@ tl r, hd r + * in + * let%bind tl' = match tl with + * | Access_record n -> ok n + * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in + * ok (I_record_patch (name', hds, [tl', annotated_expression])) + * ) + * ) + * | I_skip -> ok I_skip + * | I_fail e -> + * let%bind e' = rename_annotated_expression r e in + * ok (I_fail e') + * | I_loop (cond, body) -> + * let%bind cond' = rename_annotated_expression r cond in + * let%bind body' = rename_block r body in + * ok (I_loop (cond', body')) + * | I_matching (ae, m) -> + * let%bind ae' = rename_annotated_expression r ae in + * let%bind m' = rename_matching rename_block r m in + * ok (I_matching (ae', m')) + * | I_record_patch (v, path, lst) -> + * let aux (x, y) = + * let%bind y' = rename_annotated_expression (filter r v) y in + * ok (x, y') in + * let%bind lst' = bind_map_list aux lst in + * match List.assoc_opt v r with + * | None -> ( + * ok (I_record_patch (v, path, lst')) + * ) + * | Some (v', path') -> ( + * ok (I_record_patch (v', path' @ path, lst')) + * ) + * and rename_block (r:renamings) (bl:block) : block result = + * bind_map_list (rename_instruction r) bl + * + * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = + * fun f r m -> + * match m with + * | Match_bool { match_true = mt ; match_false = mf } -> + * let%bind match_true = f r mt in + * let%bind match_false = f r mf in + * ok (Match_bool {match_true ; match_false}) + * | Match_option { match_none = mn ; match_some = (some, ms) } -> + * let%bind match_none = f r mn in + * let%bind ms' = f (filter r some) ms in + * ok (Match_option {match_none ; match_some = (some, ms')}) + * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> + * let%bind match_nil = f r mn in + * let%bind mc' = f (filters r [hd;tl]) mc in + * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) + * | Match_tuple (lst, body) -> + * let%bind body' = f (filters r lst) body in + * ok (Match_tuple (lst, body')) + * + * and rename_matching_instruction = fun x -> rename_matching rename_block x + * + * and rename_matching_expr = fun x -> rename_matching rename_expression x + * + * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = + * let%bind expression = rename_expression r ae.expression in + * ok {ae with expression} + * + * and rename_expression : renamings -> expression -> expression result = fun r e -> + * match e with + * | E_literal _ as l -> ok l + * | E_constant (name, lst) -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_constant (name, lst')) + * | E_constructor (name, ae) -> + * let%bind ae' = rename_annotated_expression r ae in + * ok (E_constructor (name, ae')) + * | E_variable v -> ( + * match List.assoc_opt v r with + * | None -> ok (E_variable v) + * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) + * ) + * | E_lambda ({binder;body;result} as l) -> + * let r' = filter r binder in + * let%bind body = rename_block r' body in + * let%bind result = rename_annotated_expression r' result in + * ok (E_lambda {l with body ; result}) + * | E_application (f, arg) -> + * let%bind f' = rename_annotated_expression r f in + * let%bind arg' = rename_annotated_expression r arg in + * ok (E_application (f', arg')) + * | E_tuple lst -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_tuple lst') + * | E_accessor (ae, p) -> + * let%bind ae' = rename_annotated_expression r ae in + * ok (E_accessor (ae', p)) + * | E_record sm -> + * let%bind sm' = bind_smap + * @@ SMap.map (rename_annotated_expression r) sm in + * ok (E_record sm') + * | E_map m -> + * let%bind m' = bind_map_list + * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in + * ok (E_map m') + * | E_list lst -> + * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in + * ok (E_list lst') + * | E_look_up m -> + * let%bind m' = bind_map_pair (rename_annotated_expression r) m in + * ok (E_look_up m') + * | E_matching (ae, m) -> + * let%bind ae' = rename_annotated_expression r ae in + * let%bind m' = rename_matching rename_annotated_expression r m in + * ok (E_matching (ae', m')) + * end + * end *) diff --git a/src/stages/3-ast_simplified/misc.mli b/src/stages/3-ast_simplified/misc.mli new file mode 100644 index 000000000..0784d109c --- /dev/null +++ b/src/stages/3-ast_simplified/misc.mli @@ -0,0 +1,20 @@ +open Trace +open Types + + +(* + +module Errors : sig + val different_literals_because_different_types : name -> literal -> literal -> unit -> error + + val different_literals : name -> literal -> literal -> unit -> error + + val error_uncomparable_literals : name -> literal -> literal -> unit -> error +end + +val assert_literal_eq : ( literal * literal ) -> unit result +*) + +val assert_value_eq : ( expression * expression ) -> unit result + +val is_value_eq : ( expression * expression ) -> bool diff --git a/src/stages/ast_simplified/types.ml b/src/stages/3-ast_simplified/types.ml similarity index 98% rename from src/stages/ast_simplified/types.ml rename to src/stages/3-ast_simplified/types.ml index 696dbd028..ef2e32f36 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/3-ast_simplified/types.ml @@ -34,8 +34,8 @@ and expression_content = | E_variable of expression_variable | E_application of application | E_lambda of lambda - | E_let_in of let_in | E_recursive of recursive + | E_let_in of let_in | E_skip (* Variant *) | E_constructor of constructor (* For user defined constructors *) @@ -61,24 +61,23 @@ and constant = and application = {expr1: expression; expr2: expression} and lambda = - { binder: expression_variable + { binder: expression_variable ; input_type: type_expression option ; output_type: type_expression option ; result: expression } -and let_in = - { let_binder: expression_variable * type_expression option - ; mut: bool - ; rhs: expression - ; let_result: expression - ; inline: bool } - and recursive = { fun_name : expression_variable; fun_type : type_expression; lambda : lambda; } +and let_in = + { let_binder: expression_variable * type_expression option + ; rhs: expression + ; let_result: expression + ; inline: bool } + and constructor = {constructor: constructor'; element: expression} and accessor = {expr: expression; label: label} diff --git a/src/stages/ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml similarity index 100% rename from src/stages/ast_typed/PP.ml rename to src/stages/4-ast_typed/PP.ml diff --git a/src/stages/ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml similarity index 100% rename from src/stages/ast_typed/ast_typed.ml rename to src/stages/4-ast_typed/ast_typed.ml diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml similarity index 100% rename from src/stages/ast_typed/combinators.ml rename to src/stages/4-ast_typed/combinators.ml diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli similarity index 100% rename from src/stages/ast_typed/combinators.mli rename to src/stages/4-ast_typed/combinators.mli diff --git a/src/stages/ast_typed/combinators_environment.ml b/src/stages/4-ast_typed/combinators_environment.ml similarity index 100% rename from src/stages/ast_typed/combinators_environment.ml rename to src/stages/4-ast_typed/combinators_environment.ml diff --git a/src/stages/ast_typed/combinators_environment.mli b/src/stages/4-ast_typed/combinators_environment.mli similarity index 100% rename from src/stages/ast_typed/combinators_environment.mli rename to src/stages/4-ast_typed/combinators_environment.mli diff --git a/src/stages/ast_typed/dune b/src/stages/4-ast_typed/dune similarity index 100% rename from src/stages/ast_typed/dune rename to src/stages/4-ast_typed/dune diff --git a/src/stages/ast_typed/environment.ml b/src/stages/4-ast_typed/environment.ml similarity index 100% rename from src/stages/ast_typed/environment.ml rename to src/stages/4-ast_typed/environment.ml diff --git a/src/stages/ast_typed/environment.mli b/src/stages/4-ast_typed/environment.mli similarity index 100% rename from src/stages/ast_typed/environment.mli rename to src/stages/4-ast_typed/environment.mli diff --git a/src/stages/ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml similarity index 100% rename from src/stages/ast_typed/misc.ml rename to src/stages/4-ast_typed/misc.ml diff --git a/src/stages/ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli similarity index 100% rename from src/stages/ast_typed/misc.mli rename to src/stages/4-ast_typed/misc.mli diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml similarity index 100% rename from src/stages/ast_typed/misc_smart.ml rename to src/stages/4-ast_typed/misc_smart.ml diff --git a/src/stages/ast_typed/misc_smart.mli b/src/stages/4-ast_typed/misc_smart.mli similarity index 100% rename from src/stages/ast_typed/misc_smart.mli rename to src/stages/4-ast_typed/misc_smart.mli diff --git a/src/stages/ast_typed/types.ml b/src/stages/4-ast_typed/types.ml similarity index 100% rename from src/stages/ast_typed/types.ml rename to src/stages/4-ast_typed/types.ml diff --git a/src/stages/mini_c/PP.ml b/src/stages/5-mini_c/PP.ml similarity index 100% rename from src/stages/mini_c/PP.ml rename to src/stages/5-mini_c/PP.ml diff --git a/src/stages/mini_c/PP.mli b/src/stages/5-mini_c/PP.mli similarity index 100% rename from src/stages/mini_c/PP.mli rename to src/stages/5-mini_c/PP.mli diff --git a/src/stages/mini_c/combinators.ml b/src/stages/5-mini_c/combinators.ml similarity index 100% rename from src/stages/mini_c/combinators.ml rename to src/stages/5-mini_c/combinators.ml diff --git a/src/stages/mini_c/combinators.mli b/src/stages/5-mini_c/combinators.mli similarity index 100% rename from src/stages/mini_c/combinators.mli rename to src/stages/5-mini_c/combinators.mli diff --git a/src/stages/mini_c/combinators_smart.ml b/src/stages/5-mini_c/combinators_smart.ml similarity index 100% rename from src/stages/mini_c/combinators_smart.ml rename to src/stages/5-mini_c/combinators_smart.ml diff --git a/src/stages/mini_c/dune b/src/stages/5-mini_c/dune similarity index 100% rename from src/stages/mini_c/dune rename to src/stages/5-mini_c/dune diff --git a/src/stages/mini_c/environment.ml b/src/stages/5-mini_c/environment.ml similarity index 100% rename from src/stages/mini_c/environment.ml rename to src/stages/5-mini_c/environment.ml diff --git a/src/stages/mini_c/environment.mli b/src/stages/5-mini_c/environment.mli similarity index 100% rename from src/stages/mini_c/environment.mli rename to src/stages/5-mini_c/environment.mli diff --git a/src/stages/mini_c/mini_c.ml b/src/stages/5-mini_c/mini_c.ml similarity index 100% rename from src/stages/mini_c/mini_c.ml rename to src/stages/5-mini_c/mini_c.ml diff --git a/src/stages/mini_c/misc.ml b/src/stages/5-mini_c/misc.ml similarity index 100% rename from src/stages/mini_c/misc.ml rename to src/stages/5-mini_c/misc.ml diff --git a/src/stages/mini_c/types.ml b/src/stages/5-mini_c/types.ml similarity index 100% rename from src/stages/mini_c/types.ml rename to src/stages/5-mini_c/types.ml diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 10a59f4bc..223a94610 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -89,7 +89,7 @@ module Substitution = struct let _TODO = substs in failwith "TODO: T_function" - and s_simpl_type_content : Ast_simplified.type_content w = fun ~substs -> function + and s_abstr_type_content : Ast_simplified.type_content w = fun ~substs -> function | Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression sum" | Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record" | Ast_simplified.T_arrow _ -> failwith "TODO: subst: unimplemented case s_type_expression arrow" @@ -97,20 +97,20 @@ module Substitution = struct | Ast_simplified.T_operator op -> let%bind op = Ast_simplified.bind_map_type_operator - (s_simpl_type_expression ~substs) + (s_abstr_type_expression ~substs) op in (* TODO: when we have generalized operators, we might need to subst the operator name itself? *) ok @@ Ast_simplified.T_operator op | Ast_simplified.T_constant constant -> ok @@ Ast_simplified.T_constant constant - and s_simpl_type_expression : Ast_simplified.type_expression w = fun ~substs {type_content;type_meta} -> - let%bind type_content = s_simpl_type_content ~substs type_content in + and s_abstr_type_expression : Ast_simplified.type_expression w = fun ~substs {type_content;type_meta} -> + let%bind type_content = s_abstr_type_content ~substs type_content in ok @@ Ast_simplified.{type_content;type_meta} and s_type_expression : T.type_expression w = fun ~substs { type_content; type_meta } -> let%bind type_content = s_type_content ~substs type_content in - let%bind type_meta = bind_map_option (s_simpl_type_expression ~substs) type_meta in + let%bind type_meta = bind_map_option (s_abstr_type_expression ~substs) type_meta in ok @@ T.{ type_content; type_meta} and s_literal : T.literal w = fun ~substs -> function | T.Literal_unit ->