diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 10a9b346a..3a1fe5132 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -404,6 +404,9 @@ let rec simpl_expression : | "Some" -> ( return @@ e_some ~loc arg ) + | "None" -> ( + return @@ e_none ~loc () + ) | _ -> ( return @@ e_constructor ~loc c_name arg ) @@ -699,6 +702,24 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = ) | _ -> fail @@ only_constructors t in + let rec get_constr_opt (t:Raw.pattern) = + match t with + | PPar p -> get_constr_opt p.value.inside + | PConstr v -> ( + let (const , pat_opt) = v.value in + let%bind var_opt = + match pat_opt with + | None -> ok None + | Some pat -> ( + let%bind single_pat = get_single pat in + let%bind var = get_var single_pat in + ok (Some var) + ) + in + ok (const.value , var_opt) + ) + | _ -> fail @@ only_constructors t + in let%bind patterns = let aux (x , y) = let xs = get_tuple x in @@ -727,21 +748,44 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil} ) | lst -> ( - trace (simple_info "currently, only booleans, lists and constructors \ - are supported in patterns") @@ - let%bind constrs = + let error x = + let title () = "Pattern" in + let content () = + Format.asprintf "Pattern : %a" (PP_helpers.printer Raw.print_pattern) x in + error title content + in + let as_variant () = + trace (simple_info "currently, only booleans, lists, options, and constructors \ + are supported in patterns") @@ + let%bind constrs = + let aux (x , y) = + let%bind x' = + trace (error x) @@ + get_constr x + in + ok (x' , y) + in + bind_map_list aux lst + in + ok @@ Match_variant constrs + in + let as_option () = let aux (x , y) = - let error = - let title () = "Pattern" in - let content () = - Format.asprintf "Pattern : %a" (PP_helpers.printer Raw.print_pattern) x in - error title content in let%bind x' = - trace error @@ - get_constr x in - ok (x' , y) in - bind_map_list aux lst in - ok @@ Match_variant constrs + trace (error x) @@ + get_constr_opt x + in + ok (x' , y) + in + let%bind constrs = bind_map_list aux lst in + match constrs with + | [ (("Some" , Some some_var) , some_expr) ; (("None" , None) , none_expr) ] + | [ (("None" , None) , none_expr) ; (("Some" , Some some_var) , some_expr) ] -> ( + ok @@ Match_option { match_some = (some_var , some_expr) ; match_none = none_expr } + ) + | _ -> simple_fail "bad option pattern" + in + bind_or (as_option () , as_variant ()) ) let simpl_program : Raw.ast -> program result = fun t -> diff --git a/src/passes/3-self_ast_simplified/none_variant.ml b/src/passes/3-self_ast_simplified/none_variant.ml new file mode 100644 index 000000000..d64350a81 --- /dev/null +++ b/src/passes/3-self_ast_simplified/none_variant.ml @@ -0,0 +1,9 @@ +open Ast_simplified +open Trace + +let peephole_expression : expression -> expression result = fun e -> + let return expression = ok { e with expression } in + match e.expression with + | E_constructor ("Some" , e) -> return @@ E_constant ("SOME" , [ e ]) + | E_constructor ("None" , _) -> return @@ E_constant ("NONE" , [ ]) + | e -> return e diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index 6aafa38a4..b3ebb08db 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -1,2 +1,3 @@ let convert_annotation_expression = Helpers.map_expression Tezos_type_annotation.peephole_expression let convert_annotation_program = Helpers.map_program Tezos_type_annotation.peephole_expression +let convert_none_variant_to_const = Helpers.map_program None_variant.peephole_expression diff --git a/src/test/contracts/option.mligo b/src/test/contracts/option.mligo new file mode 100644 index 000000000..034871499 --- /dev/null +++ b/src/test/contracts/option.mligo @@ -0,0 +1,4 @@ +type foobar = int option + +let s : foobar = Some 42 +let n : foobar = None diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 5efcc9fc1..df2b2cb86 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -340,6 +340,18 @@ let option () : unit result = in ok () +let moption () : unit result = + let%bind program = mtype_file "./contracts/option.mligo" in + let%bind () = + let expected = e_some (e_int 42) in + expect_eq_evaluate program "s" expected + in + let%bind () = + let expected = e_typed_none t_int in + expect_eq_evaluate program "n" expected + in + ok () + let map () : unit result = let%bind program = type_file "./contracts/map.ligo" in let ez lst = @@ -692,6 +704,7 @@ let main = test_suite "Integration (End to End)" [ test "unit" unit_expression ; test "string" string_expression ; test "option" option ; + test "option (mligo)" moption ; test "map" map ; test "list" list ; test "loop" loop ;