From 0aa01ddcd8122c608da74208bcb43dbf95cb84c5 Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 22 Apr 2019 18:56:13 +0000 Subject: [PATCH] add variant expression pattern-matching --- src/ligo/ast_typed/PP.ml | 2 +- src/ligo/ast_typed/combinators.ml | 2 +- src/ligo/ast_typed/types.ml | 4 ++-- src/ligo/compiler/compiler_program.ml | 13 +++++++------ src/ligo/contracts/variant-matching.ligo | 9 +++++++++ src/ligo/contracts/variant.ligo | 5 ----- src/ligo/main/contract.ml | 4 ++-- src/ligo/main/main.ml | 8 +++++++- src/ligo/test/integration_tests.ml | 14 ++++++++++---- src/ligo/transpiler/transpiler.ml | 18 +++++++++--------- src/ligo/typer/typer.ml | 2 +- 11 files changed, 49 insertions(+), 32 deletions(-) create mode 100644 src/ligo/contracts/variant-matching.ligo diff --git a/src/ligo/ast_typed/PP.ml b/src/ligo/ast_typed/PP.ml index d319ae0ed..60ddf7b3c 100644 --- a/src/ligo/ast_typed/PP.ml +++ b/src/ligo/ast_typed/PP.ml @@ -103,7 +103,7 @@ and instruction ppf (i:instruction) = match i with let declaration ppf (d:declaration) = match d with - | Declaration_constant {name ; annotated_expression = ae} -> + | Declaration_constant ({name ; annotated_expression = ae} , _) -> fprintf ppf "const %s = %a" name annotated_expression ae let program ppf (p:program) = diff --git a/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml index 5caa7193c..1391fa29b 100644 --- a/src/ligo/ast_typed/combinators.ml +++ b/src/ligo/ast_typed/combinators.ml @@ -171,7 +171,7 @@ let get_a_bool (t:annotated_expression) = let get_declaration_by_name : program -> string -> declaration result = fun p name -> let aux : declaration -> bool = fun declaration -> match declaration with - | Declaration_constant d -> d.name = name + | Declaration_constant (d , _) -> d.name = name in trace_option (simple_error "no declaration with given name") @@ List.find_opt aux @@ List.map Location.unwrap p diff --git a/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml index a9b4bd1aa..37ca73937 100644 --- a/src/ligo/ast_typed/types.ml +++ b/src/ligo/ast_typed/types.ml @@ -14,7 +14,7 @@ type 'a type_name_map = 'a SMap.t type program = declaration Location.wrap list and declaration = - | Declaration_constant of named_expression + | Declaration_constant of (named_expression * full_environment) (* | Macro_declaration of macro_declaration *) and environment_element = { @@ -141,7 +141,7 @@ open Trace let get_entry (p:program) (entry : string) : annotated_expression result = let aux (d:declaration) = match d with - | Declaration_constant {name ; annotated_expression} when entry = name -> Some annotated_expression + | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression | Declaration_constant _ -> None in let%bind result = diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index ef4f661f0..3e77c6f95 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -300,15 +300,15 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = let%bind restrict_r = Compiler_environment.to_michelson_restrict r.environment in let%bind code = ok (seq [ c' ; i_unpair ; - i_if_none (seq [ - i_pair ; + i_if_left (seq [ + i_swap ; dip i_pair ; l' ; - i_unpair ; + i_comment "restrict left" ; dip restrict_l ; ]) (seq [ - i_pair ; + i_swap ; dip i_pair ; r' ; - i_unpair ; + i_comment "restrict right" ; dip restrict_r ; ]) ; @@ -324,7 +324,8 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = i_unpair ; i_swap ; dip i_pair ; body' ; - restrict ; + i_comment "restrict let" ; + dip restrict ; ]) in return code ) diff --git a/src/ligo/contracts/variant-matching.ligo b/src/ligo/contracts/variant-matching.ligo new file mode 100644 index 000000000..92e5588d4 --- /dev/null +++ b/src/ligo/contracts/variant-matching.ligo @@ -0,0 +1,9 @@ +type foobar is +| Foo of int +| Bar of bool + +function fb(const p : foobar) : int is + block { skip } with (case p of + | Foo (n) -> n + | Bar (t) -> 42 + end) diff --git a/src/ligo/contracts/variant.ligo b/src/ligo/contracts/variant.ligo index 4ccb21418..b2a306bc8 100644 --- a/src/ligo/contracts/variant.ligo +++ b/src/ligo/contracts/variant.ligo @@ -6,8 +6,3 @@ const foo : foobar = Foo (42) const bar : foobar = Bar (True) -function fb(const p : foobar) : int is - block { skip } with (case p of - | Foo (n) -> n - | Bar (t) -> 42 - end) diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml index 795bb2a7c..662b828f5 100644 --- a/src/ligo/main/contract.ml +++ b/src/ligo/main/contract.ml @@ -40,7 +40,7 @@ include struct let assert_valid_entry_point : program -> string -> unit result = fun p e -> let%bind declaration = get_declaration_by_name p e in match declaration with - | Declaration_constant d -> assert_entry_point_type d.annotated_expression.type_annotation + | Declaration_constant (d , _) -> assert_entry_point_type d.annotated_expression.type_annotation end let transpile_value @@ -97,7 +97,7 @@ let compile_contract_parameter : string -> string -> string -> string result = f assert_valid_entry_point typed entry_point in let%bind declaration = Ast_typed.Combinators.get_declaration_by_name typed entry_point in match declaration with - | Declaration_constant d -> ok d.annotated_expression.type_annotation + | Declaration_constant (d , _) -> ok d.annotated_expression.type_annotation in let%bind expr = let%bind raw = diff --git a/src/ligo/main/main.ml b/src/ligo/main/main.ml index bc45dd51f..ec6f4bf3a 100644 --- a/src/ligo/main/main.ml +++ b/src/ligo/main/main.ml @@ -126,7 +126,13 @@ let easy_run_typed_simplified Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content) ) ; - let%bind typed_value = type_expression input in + let%bind typed_value = + let env = + let last_declaration = Location.unwrap List.(hd @@ rev program) in + match last_declaration with + | Declaration_constant (_ , env) -> env + in + type_expression ~env input in let%bind mini_c_value = transpile_value typed_value in let%bind mini_c_result = diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 70b0ee14a..d29b2fc7f 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -22,10 +22,15 @@ let variant () : unit result = let%bind () = let expected = e_a_constructor "Bar" (e_a_bool true) in expect_evaluate program "bar" expected in - (* let%bind () = - * let make_expect = fun n -> (3 * n + 2) in - * expect_n_int program "fb" make_expect - * in *) + ok () + +let variant_matching () : unit result = + let%bind program = type_file "./contracts/variant-matching.ligo" in + let%bind () = + let make_input = fun n -> e_a_constructor "Foo" (e_a_int n) in + let make_expected = e_a_int in + expect_n program "fb" make_input make_expected + in ok () let closure () : unit result = @@ -324,6 +329,7 @@ let main = "Integration (End to End)", [ test "function" function_ ; test "complex function" complex_function ; test "variant" variant ; + test "variant matching" variant_matching ; test "closure" closure ; test "shared function" shared_function ; test "shadow" shadow ; diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index f95cd48b9..008e467c5 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -201,7 +201,7 @@ and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t r and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result = let%bind tv = translate_type ae.type_annotation in - let return ?(tv = tv) expr = + let return ?(tv = tv) ?(env = env) expr = (* let%bind env' = transpile_environment ae.environment in *) ok @@ Combinators.Expression.make_tpl (expr, tv, env) in let f = translate_annotated_expression env in @@ -374,7 +374,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express in aux tree' in - let rec aux acc t = + let rec aux (acc , env) t = let top = match acc with | None -> expr' @@ -386,26 +386,26 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in let env' = Environment.(add (name , tv) @@ extend env) in let%bind body' = translate_annotated_expression env' body in - return @@ E_let_in ((name , tv) , top , body') + return ~env:env' @@ E_let_in ((name , tv) , top , body') ) | ((`Node (a , b)) , tv) -> let%bind a' = let%bind a_ty = get_t_left tv in let a_var = "left" , a_ty in let env' = Environment.(add a_var @@ extend env) in - let%bind e = aux (Some (Expression.make (E_variable "left") a_ty env')) a in + let%bind e = aux ((Some (Expression.make (E_variable "left") a_ty env')) , env') a in ok (a_var , e) in let%bind b' = let%bind b_ty = get_t_right tv in let b_var = "right" , b_ty in let env' = Environment.(add b_var @@ extend env) in - let%bind e = aux (Some (Expression.make (E_variable "right") b_ty env')) b in + let%bind e = aux ((Some (Expression.make (E_variable "right") b_ty env')) , env') b in ok (b_var , e) in - return @@ E_if_left (top , a' , b') + return ~env @@ E_if_left (top , a' , b') in - aux None tree'' + aux (None , env) tree'' ) | AST.Match_list _ | AST.Match_tuple (_, _) -> simple_fail "only match bool and option exprs are translated yet" @@ -456,7 +456,7 @@ and translate_lambda env l = let translate_declaration env (d:AST.declaration) : toplevel_statement result = match d with - | Declaration_constant {name;annotated_expression} -> + | Declaration_constant ({name;annotated_expression} , _) -> let%bind expression = translate_annotated_expression env annotated_expression in let tv = Combinators.Expression.get_type expression in let env' = Environment.add (name, tv) env in @@ -495,7 +495,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = match lst with | [] -> None | hd :: tl -> ( - let (AST.Declaration_constant an) = temp_unwrap_loc hd in + let (AST.Declaration_constant (an , _)) = temp_unwrap_loc hd in match an.name = name with | true -> ( match an.annotated_expression.expression with diff --git a/src/ligo/typer/typer.ml b/src/ligo/typer/typer.ml index 290c421e1..5ff000b37 100644 --- a/src/ligo/typer/typer.ml +++ b/src/ligo/typer/typer.ml @@ -74,7 +74,7 @@ and type_declaration env : I.declaration -> (environment * O.declaration option) trace (constant_declaration_error name annotated_expression) @@ type_annotated_expression env annotated_expression in let env' = Environment.add_ez name ae'.type_annotation env in - ok (env', Some (O.Declaration_constant (make_n_e name ae'))) + ok (env', Some (O.Declaration_constant ((make_n_e name ae') , env'))) and type_block_full (e:environment) (b:I.block) : (O.block * environment) result = let aux (e, acc:(environment * O.instruction list)) (i:I.instruction) =