From 320d0c1a720017c44f682a4ec718ee34281a1e89 Mon Sep 17 00:00:00 2001 From: Galfour Date: Fri, 31 May 2019 19:56:51 +0000 Subject: [PATCH] various refactorings to prepare tests; tests for ligodity don't pass --- src/main/contract.ml | 4 +- src/main/main.ml | 271 +++++++++----------- src/main/run_mini_c.ml | 22 -- src/main/run_simplified.ml | 24 ++ src/main/run_source.ml | 218 ++++++++++++++++ src/main/run_typed.ml | 64 +++++ src/simplify/pascaligo.ml | 1 + src/test/bin_tests.ml | 4 +- src/test/coase_tests.ml | 4 +- src/test/heap_tests.ml | 30 ++- src/test/integration_tests.ml | 20 +- src/test/test_helpers.ml | 6 +- src/transpiler/transpiler.ml | 12 +- vendors/ligo-utils/simple-utils/trace.ml | 24 +- vendors/ligo-utils/simple-utils/x_option.ml | 3 +- 15 files changed, 484 insertions(+), 223 deletions(-) create mode 100644 src/main/run_simplified.ml create mode 100644 src/main/run_source.ml create mode 100644 src/main/run_typed.ml diff --git a/src/main/contract.ml b/src/main/contract.ml index d49cbd478..84f856c7c 100644 --- a/src/main/contract.ml +++ b/src/main/contract.ml @@ -98,7 +98,7 @@ let parsify_expression_ligodity = fun source -> let parsify = fun syntax source -> let%bind parsify = match syntax with | "pascaligo" -> ok parsify_pascaligo - | "cameligo" + | "cameligo" -> ok parsify_ligodity | _ -> simple_fail "unrecognized parser" in parsify source @@ -106,7 +106,7 @@ let parsify = fun syntax source -> let parsify_expression = fun syntax source -> let%bind parsify = match syntax with | "pascaligo" -> ok parsify_expression_pascaligo - | "cameligo" + | "cameligo" -> ok parsify_expression_ligodity | _ -> simple_fail "unrecognized parser" in parsify source diff --git a/src/main/main.ml b/src/main/main.ml index 15f2dde7d..b24f522d4 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -1,6 +1,6 @@ module Run_mini_c = Run_mini_c -open Trace +(* open Trace *) module Parser = Parser module AST_Raw = Parser.Pascaligo.AST module AST_Simplified = Ast_simplified @@ -8,159 +8,128 @@ module AST_Typed = Ast_typed module Mini_c = Mini_c module Typer = Typer module Transpiler = Transpiler + +module Run = struct + include Run_source + include Run_simplified + include Run_typed + include Run_mini_c +end + (* module Parser_multifix = Multifix * module Simplify_multifix = Simplify_multifix *) -let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p -let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e -let unparse_simplified_expr (e:AST_Simplified.expression) : string result = - ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e - -let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p -let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) - (e:AST_Simplified.expression) : AST_Typed.annotated_expression result = - Typer.type_expression env e -let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e - -let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p -let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name -let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e -let transpile_value - (e:AST_Typed.annotated_expression) : Mini_c.value result = - let%bind f = - let open Transpiler in - let (f , _) = functionalize e in - let%bind main = translate_main f in - ok main - in - - let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f input in - ok r - -let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = - Transpiler.untranspile v e - -let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program - -let type_file ?(debug_simplify = false) ?(debug_typed = false) - (path:string) : AST_Typed.program result = - let%bind raw = Parser.Pascaligo.parse_file path in - let%bind simpl = - trace (simple_error "simplifying") @@ - simplify raw in - (if debug_simplify then - Format.(printf "Simplified : %a\n%!" AST_Simplified.PP.program simpl) - ) ; - let%bind typed = - trace (simple_error "typing") @@ - type_ simpl in - (if debug_typed then ( - Format.(printf "Typed : %a\n%!" AST_Typed.PP.program typed) - )) ; - ok typed +(* let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p + * let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e + * let unparse_simplified_expr (e:AST_Simplified.expression) : string result = + * ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e + * + * let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p + * let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty) + * (e:AST_Simplified.expression) : AST_Typed.annotated_expression result = + * Typer.type_expression env e + * let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e + * + * let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p + * let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name + * let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e + * + * let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result = + * Transpiler.untranspile v e + * + * let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program + * + * let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = + * let%bind result = + * let%bind mini_c_main = + * transpile_entry program entry in + * Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + * let%bind typed_result = + * let%bind typed_main = Ast_typed.get_entry program entry in + * untranspile_value result typed_main.type_annotation in + * ok typed_result + * + * + * let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") + * + * + * let easy_run_typed + * ?(debug_mini_c = false) ?options (entry:string) + * (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = + * let%bind () = + * let open Ast_typed in + * let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in + * let%bind (arg_ty , _) = + * trace_strong (simple_error "entry-point doesn't have a function type") @@ + * get_t_function @@ get_type_annotation d.annotated_expression in + * Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) + * in + * + * let%bind mini_c_main = + * trace (simple_error "transpile mini_c entry") @@ + * transpile_entry program entry in + * (if debug_mini_c then + * Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + * ) ; + * + * let%bind mini_c_value = transpile_value input in + * + * let%bind mini_c_result = + * let error = + * let title () = "run Mini_c" in + * let content () = + * Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + * in + * error title content in + * trace error @@ + * Run_mini_c.run_entry ?options mini_c_main mini_c_value in + * let%bind typed_result = + * let%bind main_result_type = + * let%bind typed_main = Ast_typed.get_functional_entry program entry in + * match (snd typed_main).type_value' with + * | T_function (_, result) -> ok result + * | _ -> simple_fail "main doesn't have fun type" in + * untranspile_value mini_c_result main_result_type in + * ok typed_result + * + * let easy_run_typed_simplified + * ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) + * (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result = + * let%bind mini_c_main = + * trace (simple_error "transpile mini_c entry") @@ + * transpile_entry program entry in + * (if debug_mini_c then + * Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + * ) ; + * + * let%bind typed_value = + * let env = + * let last_declaration = Location.unwrap List.(hd @@ rev program) in + * match last_declaration with + * | Declaration_constant (_ , (_ , post_env)) -> post_env + * in + * type_expression ~env input in + * let%bind mini_c_value = transpile_value typed_value in + * + * let%bind mini_c_result = + * let error = + * let title () = "run Mini_c" in + * let content () = + * Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + * in + * error title content in + * trace error @@ + * Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in + * let%bind typed_result = + * let%bind main_result_type = + * let%bind typed_main = Ast_typed.get_functional_entry program entry in + * match (snd typed_main).type_value' with + * | T_function (_, result) -> ok result + * | _ -> simple_fail "main doesn't have fun type" in + * untranspile_value mini_c_result main_result_type in + * let%bind annotated_result = untype_expression typed_result in + * ok annotated_result *) -let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result = - let%bind result = - let%bind mini_c_main = - transpile_entry program entry in - Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - untranspile_value result typed_main.type_annotation in - ok typed_result - -let easy_evaluate_typed_simplified (entry:string) (program:AST_Typed.program) : Ast_simplified.expression result = - let%bind result = - let%bind mini_c_main = - transpile_entry program entry in - Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in - let%bind typed_result = - let%bind typed_main = Ast_typed.get_entry program entry in - untranspile_value result typed_main.type_annotation in - let%bind annotated_result = untype_expression typed_result in - ok annotated_result - -let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed") - -let easy_run_typed - ?(debug_mini_c = false) ?options (entry:string) - (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result = - let%bind () = - let open Ast_typed in - let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in - let%bind (arg_ty , _) = - trace_strong (simple_error "entry-point doesn't have a function type") @@ - get_t_function @@ get_type_annotation d.annotated_expression in - Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) - in - - let%bind mini_c_main = - trace (simple_error "transpile mini_c entry") @@ - transpile_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - ) ; - - let%bind mini_c_value = transpile_value input in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - in - error title content in - trace error @@ - Run_mini_c.run_entry ?options mini_c_main mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - untranspile_value mini_c_result main_result_type in - ok typed_result - -let easy_run_typed_simplified - ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) - (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result = - let%bind mini_c_main = - trace (simple_error "transpile mini_c entry") @@ - transpile_entry program entry in - (if debug_mini_c then - Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) - ) ; - - let%bind typed_value = - let env = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env - in - type_expression ~env input in - let%bind mini_c_value = transpile_value typed_value in - - let%bind mini_c_result = - let error = - let title () = "run Mini_c" in - let content () = - Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main - in - error title content in - trace error @@ - Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in - let%bind typed_result = - let%bind main_result_type = - let%bind typed_main = Ast_typed.get_functional_entry program entry in - match (snd typed_main).type_value' with - | T_function (_, result) -> ok result - | _ -> simple_fail "main doesn't have fun type" in - untranspile_value mini_c_result main_result_type in - let%bind annotated_result = untype_expression typed_result in - ok annotated_result - - -module Contract = Contract +(* module Contract = Contract *) diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index adad4c05c..17fc40ba2 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -22,14 +22,6 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let run_node (program:program) (input:Michelson.t) : Michelson.t result = - let%bind compiled = translate_program program "main" in - let%bind (Ex_typed_value (output_ty, output)) = run_aux compiled input in - let%bind output = - Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@ - Memory_proto_alpha.unparse_michelson_data output_ty output in - ok output - let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result = let%bind compiled = let error = @@ -45,17 +37,3 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v let%bind ex_ty_value = run_aux ?options compiled input_michelson in let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in ok result - -let run (program:program) (input:value) : value result = - let%bind input_michelson = translate_value input in - let%bind compiled = translate_program program "main" in - let%bind ex_ty_value = run_aux compiled input_michelson in - let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in - ok result - -let expression_to_value (e:expression) : value result = - match (Combinators.Expression.get_content e) with - | E_literal v -> ok v - | _ -> fail - @@ error (thunk "not a value") - @@ (fun () -> Format.asprintf "%a" PP.expression e) diff --git a/src/main/run_simplified.ml b/src/main/run_simplified.ml new file mode 100644 index 000000000..898ba6954 --- /dev/null +++ b/src/main/run_simplified.ml @@ -0,0 +1,24 @@ +open Trace + +let run_simplityped + ?options + ?(debug_mini_c = false) ?(debug_michelson = false) + (program : Ast_typed.program) (entry : string) + (input : Ast_simplified.expression) : Ast_simplified.expression result = + let%bind typed_input = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env + in + Typer.type_expression env input in + let%bind typed_result = + Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in + let%bind annotated_result = Typer.untype_expression typed_result in + ok annotated_result + +let evaluate_simplityped (program : Ast_typed.program) (entry : string) + : Ast_simplified.expression result = + let%bind typed_result = Run_typed.evaluate_typed entry program in + let%bind annotated_result = Typer.untype_expression typed_result in + ok annotated_result diff --git a/src/main/run_source.ml b/src/main/run_source.ml new file mode 100644 index 000000000..1c452c91d --- /dev/null +++ b/src/main/run_source.ml @@ -0,0 +1,218 @@ +open Trace + +include struct + open Ast_simplified + + let assert_entry_point_defined : program -> string -> unit result = + fun program entry_point -> + let aux : declaration -> bool = fun declaration -> + match declaration with + | Declaration_type _ -> false + | Declaration_constant (name , _ , _) -> name = entry_point + in + trace_strong (simple_error "no entry-point with given name") @@ + Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program +end + +include struct + open Ast_typed + open Combinators + + let get_entry_point_type : type_value -> (type_value * type_value) result = fun t -> + let%bind (arg , result) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function t in + let%bind (arg' , storage_param) = + trace_strong (simple_error "entry-point doesn't have 2 parameters") @@ + get_t_pair arg in + let%bind (ops , storage_result) = + trace_strong (simple_error "entry-point doesn't have 2 results") @@ + get_t_pair result in + let%bind () = + trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@ + assert_t_list_operation ops in + let%bind () = + trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@ + assert_type_value_eq (storage_param , storage_result) in + ok (arg' , storage_param) + + let get_entry_point : program -> string -> (type_value * type_value) result = fun p e -> + let%bind declaration = get_declaration_by_name p e in + match declaration with + | Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation + + let assert_valid_entry_point = fun p e -> + let%bind _ = get_entry_point p e in + ok () +end + +let transpile_value + (e:Ast_typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f in + ok main + in + + let input = Mini_c.Combinators.d_unit in + let%bind r = Run_mini_c.run_entry f input in + ok r + +let parsify_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Pascaligo.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Pascaligo.simpl_program raw in + ok simplified + +let parsify_expression_pascaligo = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Pascaligo.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Pascaligo.simpl_expression raw in + ok simplified + +let parsify_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing") @@ + Parser.Ligodity.parse_file source in + let%bind simplified = + trace (simple_error "simplifying") @@ + Simplify.Ligodity.simpl_program raw in + ok simplified + +let parsify_expression_ligodity = fun source -> + let%bind raw = + trace (simple_error "parsing expression") @@ + Parser.Ligodity.parse_expression source in + let%bind simplified = + trace (simple_error "simplifying expression") @@ + Simplify.Ligodity.simpl_expression raw in + ok simplified + +let parsify = fun syntax source -> + let%bind parsify = match syntax with + | "pascaligo" -> ok parsify_pascaligo + | "cameligo" -> ok parsify_ligodity + | _ -> simple_fail "unrecognized parser" + in + parsify source + +let parsify_expression = fun syntax source -> + let%bind parsify = match syntax with + | "pascaligo" -> ok parsify_expression_pascaligo + | "cameligo" -> ok parsify_expression_ligodity + | _ -> simple_fail "unrecognized parser" + in + parsify source + +let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax -> + let%bind simplified = parsify syntax source in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simplified in + let%bind mini_c = + trace (simple_error "transpiling") @@ + Transpiler.translate_entry typed entry_point in + let%bind michelson = + trace (simple_error "compiling") @@ + Compiler.translate_contract mini_c in + let str = + Format.asprintf "%a" Michelson.pp_stripped michelson in + ok str + +let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> + let%bind (program , parameter_tv) = + let%bind simplified = parsify syntax source in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing file") @@ + Typer.type_program simplified in + let%bind (param_ty , _) = + get_entry_point typed entry_point in + ok (typed , param_ty) + in + let%bind expr = + let%bind typed = + let%bind simplified = parsify_expression syntax expression in + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env + in + trace (simple_error "typing expression") @@ + Typer.type_expression env simplified in + let%bind () = + trace (simple_error "expression type doesn't match type parameter") @@ + Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in + let%bind mini_c = + trace (simple_error "transpiling expression") @@ + transpile_value typed in + let%bind michelson = + trace (simple_error "compiling expression") @@ + Compiler.translate_value mini_c in + let str = + Format.asprintf "%a" Michelson.pp_stripped michelson in + ok str + in + ok expr + + +let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> + let%bind (program , storage_tv) = + let%bind simplified = parsify syntax source in + let%bind () = + assert_entry_point_defined simplified entry_point in + let%bind typed = + trace (simple_error "typing file") @@ + Typer.type_program simplified in + let%bind (_ , storage_ty) = + get_entry_point typed entry_point in + ok (typed , storage_ty) + in + let%bind expr = + let%bind simplified = parsify_expression syntax expression in + let%bind typed = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , (_ , post_env)) -> post_env + in + trace (simple_error "typing expression") @@ + Typer.type_expression env simplified in + let%bind () = + trace (simple_error "expression type doesn't match type storage") @@ + Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in + let%bind mini_c = + trace (simple_error "transpiling expression") @@ + transpile_value typed in + let%bind michelson = + trace (simple_error "compiling expression") @@ + Compiler.translate_value mini_c in + let str = + Format.asprintf "%a" Michelson.pp_stripped michelson in + ok str + in + ok expr + +let type_file ?(debug_simplify = false) ?(debug_typed = false) + syntax (path:string) : Ast_typed.program result = + let%bind simpl = parsify syntax path in + (if debug_simplify then + Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) + ) ; + let%bind typed = + trace (simple_error "typing") @@ + Typer.type_program simpl in + (if debug_typed then ( + Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed) + )) ; + ok typed diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml new file mode 100644 index 000000000..a7f9fdc58 --- /dev/null +++ b/src/main/run_typed.ml @@ -0,0 +1,64 @@ +open Trace + +let transpile_value + (e:Ast_typed.annotated_expression) : Mini_c.value result = + let%bind f = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f in + ok main + in + + let input = Mini_c.Combinators.d_unit in + let%bind r = Run_mini_c.run_entry f input in + ok r + +let evaluate_typed (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = + trace (simple_error "easy evaluate typed") @@ + let%bind result = + let%bind mini_c_main = + Transpiler.translate_entry program entry in + Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + let%bind typed_result = + let%bind typed_main = Ast_typed.get_entry program entry in + Transpiler.untranspile result typed_main.type_annotation in + ok typed_result + +let run_typed + ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) + (program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + let%bind () = + let open Ast_typed in + let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in + let%bind (arg_ty , _) = + trace_strong (simple_error "entry-point doesn't have a function type") @@ + get_t_function @@ get_type_annotation d.annotated_expression in + Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) + in + + let%bind mini_c_main = + trace (simple_error "transpile mini_c entry") @@ + Transpiler.translate_entry program entry in + (if debug_mini_c then + Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + ) ; + + let%bind mini_c_value = transpile_value input in + + let%bind mini_c_result = + let error = + let title () = "run Mini_c" in + let content () = + Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main + in + error title content in + trace error @@ + Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in + let%bind typed_result = + let%bind main_result_type = + let%bind typed_main = Ast_typed.get_functional_entry program entry in + match (snd typed_main).type_value' with + | T_function (_, result) -> ok result + | _ -> simple_fail "main doesn't have fun type" in + Transpiler.untranspile mini_c_result main_result_type in + ok typed_result diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index 038fd4484..bf907b1fb 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -351,6 +351,7 @@ and simpl_fun_declaration : Raw.fun_decl -> ((name * type_expression option) * e let arguments_name = "arguments" in let%bind params = bind_map_list simpl_param lst in let (binder , input_type) = + (* let type_expression = T_record (SMap.of_list params) in *) let type_expression = T_tuple (List.map snd params) in (arguments_name , type_expression) in let%bind tpl_declarations = diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index f159e6287..cef36ab94 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -1,10 +1,10 @@ open Trace -open Ligo +open Ligo.Run open Test_helpers let compile_contract_basic () : unit result = let%bind _ = - Contract.compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo" + compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo" in ok () diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 4d15754db..e6e086c6c 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -1,9 +1,11 @@ (* Copyright Coase, Inc 2019 *) open Trace -open Ligo +open Ligo.Run open Test_helpers +let type_file = type_file "pascaligo" + let get_program = let s = ref None in fun () -> match !s with diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index 002ae9dbf..c52205720 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -1,7 +1,9 @@ open Trace -open Ligo +open Ligo.Run open Test_helpers +let type_file = type_file "pascaligo" + let get_program = let s = ref None in fun () -> match !s with @@ -12,8 +14,8 @@ let get_program = ok program ) -let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) = - let open AST_Typed.Combinators in +let a_heap_ez ?value_type (content:(int * Ast_typed.ae) list) = + let open Ast_typed.Combinators in let content = let aux = fun (x, y) -> e_a_empty_nat x, y in List.map aux content in @@ -24,7 +26,7 @@ let a_heap_ez ?value_type (content:(int * AST_Typed.ae) list) = e_a_empty_map content (t_nat ()) value_type let ez lst = - let open AST_Typed.Combinators in + let open Ast_typed.Combinators in let value_type = t_pair (t_int ()) (t_string ()) @@ -46,11 +48,11 @@ let dummy n = let is_empty () : unit result = let%bind program = get_program () in let aux n = - let open AST_Typed.Combinators in + let open Ast_typed.Combinators in let input = dummy n in - let%bind result = easy_run_typed "is_empty" program input in + let%bind result = run_typed "is_empty" program input in let expected = e_a_empty_bool (n = 0) in - AST_Typed.assert_value_eq (expected, result) + Ast_typed.assert_value_eq (expected, result) in let%bind _ = bind_list @@ List.map aux @@ -60,15 +62,15 @@ let is_empty () : unit result = let get_top () : unit result = let%bind program = get_program () in let aux n = - let open AST_Typed.Combinators in + let open Ast_typed.Combinators in let input = dummy n in - match n, easy_run_typed "get_top" program input with + match n, run_typed "get_top" program input with | 0, Trace.Ok _ -> simple_fail "unexpected success" | 0, _ -> ok () | _, result -> let%bind result' = result in let expected = e_a_empty_pair (e_a_empty_int 1) (e_a_empty_string "1") in - AST_Typed.assert_value_eq (expected, result') + Ast_typed.assert_value_eq (expected, result') in let%bind _ = bind_list @@ List.map aux @@ -79,7 +81,7 @@ let pop_switch () : unit result = let%bind program = get_program () in let aux n = let input = dummy n in - match n, easy_run_typed "pop_switch" program input with + match n, run_typed "pop_switch" program input with | 0, Trace.Ok _ -> simple_fail "unexpected success" | 0, _ -> ok () | _, result -> @@ -89,7 +91,7 @@ let pop_switch () : unit result = @@ tl @@ range (n + 1) ) in - AST_Typed.assert_value_eq (expected, result') + Ast_typed.assert_value_eq (expected, result') in let%bind _ = bind_list @@ List.map aux @@ -100,9 +102,9 @@ let pop () : unit result = let%bind program = get_program () in let aux n = let input = dummy n in - (match easy_run_typed "pop" program input with + (match run_typed "pop" program input with | Trace.Ok (output , _) -> ( - Format.printf "\nPop output on %d : %a\n" n AST_Typed.PP.annotated_expression output ; + Format.printf "\nPop output on %d : %a\n" n Ast_typed.PP.annotated_expression output ; ) | Errors errs -> ( Format.printf "\nPop output on %d : error\n" n) ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index ccbf6e893..ccf47465b 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1,14 +1,11 @@ open Trace -open Ligo +open Ligo.Run open Test_helpers open Ast_simplified.Combinators -let mtype_file path : Ast_typed.program result = - let%bind raw = Parser.Camligo.User.parse_file path in - let%bind simpl = Simplify.Camligo.main raw in - let%bind typed = Ligo.Typer.type_program (Location.unwrap simpl) in - ok typed +let mtype_file = type_file "cameligo" +let type_file = type_file "pascaligo" let function_ () : unit result = let%bind program = type_file "./contracts/function.ligo" in @@ -148,6 +145,9 @@ let include_ () : unit result = let record_ez_int names n = ez_e_record @@ List.map (fun x -> x, e_int n) names +let tuple_ez_int names n = + e_tuple @@ List.map (fun _ -> e_int n) names + let multiple_parameters () : unit result = let%bind program = type_file "./contracts/multiple-parameters.ligo" in let aux ((name : string) , make_input , make_output) = @@ -155,9 +155,9 @@ let multiple_parameters () : unit result = expect_eq_n program name make_input make_output' in let%bind _ = bind_list @@ List.map aux [ - ("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ; - ("abcd", record_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ; - ("abcde", record_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; + ("ab", tuple_ez_int ["a";"b"], fun n -> 2 * n) ; + ("abcd", tuple_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ; + ("abcde", tuple_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; ] in ok () @@ -437,7 +437,7 @@ let dispatch_counter_contract () : unit result = let basic_mligo () : unit result = let%bind typed = mtype_file "./contracts/basic.mligo" in - let%bind result = Ligo.easy_evaluate_typed "foo" typed in + let%bind result = evaluate_typed "foo" typed in Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result) let counter_mligo () : unit result = diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 2b9ff0f44..e1a026af3 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -3,7 +3,7 @@ open! Trace let test name f = Alcotest.test_case name `Quick @@ fun () -> let result = - trace (fun () -> error (thunk "running test") (fun () -> name) ()) @@ + trace (fun () -> error (thunk "running test") (thunk name) ()) @@ f () in match result with | Ok ((), annotations) -> ignore annotations; () @@ -20,7 +20,7 @@ let expect ?options program entry_point input expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.easy_run_typed_simplified ~debug_michelson:true ?options entry_point program input in + Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in expecter result let expect_eq ?options program entry_point input expected = @@ -41,7 +41,7 @@ let expect_evaluate program entry_point expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace error @@ - let%bind result = Ligo.easy_evaluate_typed_simplified entry_point program in + let%bind result = Ligo.Run.evaluate_simplityped program entry_point in expecter result let expect_eq_evaluate program entry_point expected = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 98792fe6b..a146358fa 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -469,7 +469,7 @@ let translate_main (l:AST.lambda) : anon_function result = | E_literal (D_function f) -> ok f | _ -> simple_fail "main is not a function" -(* From a non-functional expression [expr], build the functional expression [fun () -> expr] *) +(* From an expression [expr], build the expression [fun () -> expr] *) let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = let t = e.type_annotation in let open! AST in @@ -511,16 +511,6 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = open Combinators -let rec exp x n = - if n = 0 - then 1 - else - let exp' = exp (x * x) (n / 2) in - let m = if n mod 2 = 0 then 1 else x in - m * exp' - -let exp2 = exp 2 - let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = let open Append_tree in let rec aux tv : (string * value * AST.type_value) result= diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index c13f852b6..506ad253b 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -131,7 +131,7 @@ let mk_error let data' = let aux (key , value) = (key , `String (value ())) in X_option.map (fun x -> ("data" , `Assoc (List.map aux x))) data in - let message' = X_option.map (fun x -> ("message " , `String (x ()))) message in + let message' = X_option.map (fun x -> ("message" , `String (x ()))) message in `Assoc (X_option.collapse_list [ error_code' ; title' ; message' ; data' ]) let error title message () = mk_error ~title:(title) ~message:(message) () @@ -467,12 +467,26 @@ module Assert = struct end let json_of_error = J.to_string + let error_pp out (e : error) = let open JSON_string_utils in - let message = e |> member "message" |> string || "(no message)" in - let title = e |> member "title" |> string || "(no title)" in - let error_code = e |> member "error_code" |> int |> string_of_int || "no error code" in - Format.fprintf out "%s (%s): %s" title error_code message + let message = e |> member "message" |> J.to_string in + let error_code = + let error_code = e |> member "error_code" in + match error_code with + | `Null -> "" + | _ -> " (" ^ (J.to_string error_code) ^ ")" in + let title = e |> member "title" |> J.to_string in + let data = + let data = e |> member "data" in + match data with + | `Null -> "" + | _ -> J.to_string data in + Format.fprintf out "%s (%s): %s. %s" title error_code message data + +(* let error_pp out (e : error) = + * Format.fprintf out "%s" @@ json_of_error e *) + let error_pp_short out (e : error) = let open JSON_string_utils in diff --git a/vendors/ligo-utils/simple-utils/x_option.ml b/vendors/ligo-utils/simple-utils/x_option.ml index b538b7028..ad69d5303 100644 --- a/vendors/ligo-utils/simple-utils/x_option.ml +++ b/vendors/ligo-utils/simple-utils/x_option.ml @@ -27,8 +27,7 @@ let to_list = function | None -> [] | Some x -> [ x ] let collapse_list = fun l -> - List.concat - @@ List.map to_list l + List.concat @@ List.map to_list l (* Combinators *) let bind_eager_or = fun a b -> match (a , b) with