diff --git a/src/contracts/counter.mligo b/src/contracts/counter.mligo index 0cfa95bdf..b15f67905 100644 --- a/src/contracts/counter.mligo +++ b/src/contracts/counter.mligo @@ -1,4 +1,4 @@ type storage = int let%entry main (p:int) storage = - (list [] : operation list , p + storage) + ((list [] : operation list) , p + storage) diff --git a/src/contracts/type-alias.ligo b/src/contracts/type-alias.ligo new file mode 100644 index 000000000..c62b15f9e --- /dev/null +++ b/src/contracts/type-alias.ligo @@ -0,0 +1,3 @@ +type toto is int + +const foo : toto = 23 \ No newline at end of file diff --git a/src/main/contract.ml b/src/main/contract.ml deleted file mode 100644 index 84f856c7c..000000000 --- a/src/main/contract.ml +++ /dev/null @@ -1,204 +0,0 @@ -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 diff --git a/src/parser/ligodity.ml b/src/parser/ligodity.ml index 9d49908b6..81ee4183e 100644 --- a/src/parser/ligodity.ml +++ b/src/parser/ligodity.ml @@ -4,15 +4,18 @@ module Parser = Parser_ligodity.Parser module AST = Parser_ligodity.AST let parse_file (source: string) : AST.t result = + (* let pp_input = + * let prefix = Filename.(source |> basename |> remove_extension) + * and suffix = ".pp.ligo" + * in prefix ^ suffix in *) + + (* let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" + * source pp_input in + * let%bind () = sys_command cpp_cmd in *) + let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.ligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in - let%bind () = sys_command cpp_cmd in - + source + in let%bind channel = generic_try (simple_error "error opening file") @@ (fun () -> open_in pp_input) in diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli index f23b40375..d235b72f4 100644 --- a/src/parser/ligodity/AST.mli +++ b/src/parser/ligodity/AST.mli @@ -486,3 +486,4 @@ val unpar : expr -> expr val print_projection : projection -> unit val print_pattern : pattern -> unit +val print_expr : expr -> unit diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index 0c3398758..168980383 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -100,6 +100,14 @@ let rec simpl_expression : let mk_let_in binder rhs result = E_let_in {binder; rhs; result} in + trace ( + let title () = "simplifying expression" in + let message () = "" in + let data = [ + ("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t) + ] in + error ~data title message + ) @@ match t with | Raw.ELetIn e -> ( let Raw.{binding; body; _} = e.value in @@ -194,7 +202,7 @@ let rec simpl_expression : | EString _ -> simple_fail "string: not supported yet" | ELogic l -> simpl_logic_expression ?te_annot l | EList l -> simpl_list_expression ?te_annot l - | ECase c -> + | ECase c -> ( let%bind e = simpl_expression c.value.expr in let%bind lst = let aux (x : Raw.expr Raw.case_clause) = @@ -204,8 +212,31 @@ let rec simpl_expression : @@ List.map aux @@ List.map get_value @@ npseq_to_list c.value.cases.value in - let%bind cases = simpl_cases lst in - return @@ E_matching (e, cases) + let default_action () = + let%bind cases = simpl_cases lst in + return @@ E_matching (e , cases) in + (* Hack to take care of patterns introduced by `parser/ligodity/Parser.mly` in "norm_fun_expr" *) + match lst with + | [ (pattern , rhs) ] -> ( + match pattern with + | Raw.PPar p -> ( + let p' = p.value.inside in + match p' with + | Raw.PTyped x -> ( + let x' = x.value in + match x'.pattern with + | Raw.PVar y -> + let var_name = y.value in + let%bind type_expr = simpl_type_expression x'.type_expr in + return @@ e_let_in (var_name , Some type_expr) e rhs + | _ -> default_action () + ) + | _ -> default_action () + ) + | _ -> default_action () + ) + | _ -> default_action () + ) | EFun lamb -> let%bind input_type = bind_map_option (fun (_,type_expr) -> simpl_type_expression type_expr) @@ -237,6 +268,8 @@ let rec simpl_expression : let%bind match_true = simpl_expression c.ifso in let%bind match_false = simpl_expression c.ifnot in return @@ E_matching (expr, (Match_bool {match_true; match_false})) + + and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = let return x = ok @@ make_option_typed x te_annot in match t with @@ -302,7 +335,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu let {name;type_expr} : Raw.type_decl = x.value in let%bind type_expression = simpl_type_expression type_expr in ok @@ loc x @@ Declaration_type (name.value , type_expression) - | LetEntry _ -> simple_fail "no entry point yet" + | LetEntry x (* -> simple_fail "no entry point yet" *) | Let x -> ( let _, binding = x.value in let {variable ; lhs_type ; let_rhs} = binding in @@ -392,4 +425,4 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - ) let simpl_program : Raw.ast -> program result = fun t -> - bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl + bind_list @@ List.map simpl_declaration @@ List.rev @@ nseq_to_list t.decl diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index ccf47465b..6f8a947f7 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -4,9 +4,13 @@ open Test_helpers open Ast_simplified.Combinators -let mtype_file = type_file "cameligo" +let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed "cameligo" let type_file = type_file "pascaligo" +let type_alias () : unit result = + let%bind program = type_file "./contracts/type-alias.ligo" in + expect_eq_evaluate program "foo" (e_int 23) + let function_ () : unit result = let%bind program = type_file "./contracts/function.ligo" in let make_expect = fun n -> n in @@ -436,7 +440,7 @@ let dispatch_counter_contract () : unit result = expect_eq_n program "main" make_input make_expected let basic_mligo () : unit result = - let%bind typed = mtype_file "./contracts/basic.mligo" in + let%bind typed = mtype_file ~debug_simplify:true "./contracts/basic.mligo" 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) @@ -453,6 +457,7 @@ let guess_the_hash_mligo () : unit result = expect_eq_n program "main" make_input make_expected let main = "Integration (End to End)", [ + test "type alias" type_alias ; test "function" function_ ; test "assign" assign ; test "declaration local" declaration_local ; diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 70b1df25f..0567be391 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -357,16 +357,31 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a } -> ( let%bind input_type = let%bind input_type = - trace_option (simple_error "no input type provided") @@ - input_type in + (* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *) + let default_action () = simple_fail "no input type provided" in + match input_type with + | Some ty -> ok ty + | None -> ( + match result with + | I.E_let_in li -> ( + match li.rhs with + | I.E_variable name when name = (fst binder) -> ( + match snd li.binder with + | Some ty -> ok ty + | None -> default_action () + ) + | _ -> default_action () + ) + | _ -> default_action () + ) + in evaluate_type e input_type in let%bind output_type = - let%bind output_type = - trace_option (simple_error "no output type provided") @@ - output_type in - evaluate_type e output_type in + bind_map_option (evaluate_type e) output_type + in let e' = Environment.add_ez_binder (fst binder) input_type e in - let%bind result = type_expression ~tv_opt:output_type e' result in + let%bind result = type_expression ?tv_opt:output_type e' result in + let output_type = result.type_annotation in return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ()) ) | E_constant (name, lst) ->