From ad79188c4f1cdbe24d933d5116516bb7093d94c4 Mon Sep 17 00:00:00 2001 From: galfour Date: Sat, 21 Sep 2019 09:12:00 +0200 Subject: [PATCH] add list pattern matching --- src/passes/4-typer/typer.ml | 8 ++++---- src/passes/6-transpiler/transpiler.ml | 17 +++++++++++++++-- src/passes/8-compiler/compiler_program.ml | 18 ++++++++++++++++++ src/stages/ast_typed/PP.ml | 4 ++-- src/stages/ast_typed/misc.ml | 2 +- src/stages/ast_typed/misc_smart.ml | 2 +- src/stages/ast_typed/types.ml | 2 +- src/stages/mini_c/PP.ml | 1 + src/stages/mini_c/types.ml | 1 + src/test/integration_tests.ml | 2 +- vendors/ligo-utils/tezos-utils/x_michelson.ml | 1 + 11 files changed, 46 insertions(+), 12 deletions(-) diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index edc9d05b8..cd27b1cf4 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -274,7 +274,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t let e' = Environment.add_ez_binder hd t_list e in let e' = Environment.add_ez_binder tl t e' in let%bind b' = f e' b in - ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) + ok (O.Match_list {match_nil ; match_cons = (((hd , t_list), (tl , t)), b')}) | Match_tuple (lst, b) -> let%bind t_tuple = trace_strong (match_error ~expected:i ~actual:t loc) @@ -646,7 +646,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a let aux (cur:O.value O.matching) = match cur with | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] - | Match_list { match_nil ; match_cons = (_ , _ , match_cons) } -> [ match_nil ; match_cons ] + | Match_list { match_nil ; match_cons = ((_ , _) , match_cons) } -> [ match_nil ; match_cons ] | Match_option { match_none ; match_some = (_ , match_some) } -> [ match_none ; match_some ] | Match_tuple (_ , match_tuple) -> [ match_tuple ] | Match_variant (lst , _) -> List.map snd lst in @@ -862,10 +862,10 @@ and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matchin let%bind some = f some in let match_some = fst v, some in ok @@ Match_option {match_none ; match_some} - | Match_list {match_nil ; match_cons = (hd, tl, cons)} -> + | Match_list {match_nil ; match_cons = (((hd_name , _) , (tl_name , _)), cons)} -> let%bind match_nil = f match_nil in let%bind cons = f cons in - let match_cons = hd, tl, cons in + let match_cons = hd_name , tl_name , cons in ok @@ Match_list {match_nil ; match_cons} | Match_variant (lst , _) -> let aux ((a,b),c) = diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 8e65cfdb7..76ca3a770 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -448,8 +448,22 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind (tv' , s') = let%bind tv' = transpile_type tv in let%bind s' = transpile_annotated_expression s in - ok (tv' , s') in + ok (tv' , s') + in return @@ E_if_none (expr' , n , ((name , tv') , s')) + | Match_list { + match_nil ; + match_cons = (((hd_name , hd_ty) , (tl_name , tl_ty)) , match_cons) ; + } -> ( + let%bind nil = transpile_annotated_expression match_nil in + let%bind cons = + let%bind hd_ty' = transpile_type hd_ty in + let%bind tl_ty' = transpile_type tl_ty in + let%bind match_cons' = transpile_annotated_expression match_cons in + ok (((hd_name , hd_ty') , (tl_name , tl_ty')) , match_cons') + in + return @@ E_if_cons (expr' , nil , cons) + ) | Match_variant (lst , variant) -> ( let%bind tree = trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@ @@ -498,7 +512,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re trace_strong (corner_case ~loc:__LOC__ "building constructor") @@ aux expr' tree'' ) - | AST.Match_list _ -> fail @@ unsupported_pattern_matching "list" ae.location | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location ) diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 1e7ff7d51..bf0193fe3 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -256,6 +256,24 @@ and translate_expression (expr:expression) (env:environment) : michelson result ]) in return code ) + | E_if_cons (cond , nil , ((hd , tl) , cons)) -> ( + let%bind cond' = translate_expression cond env in + let%bind nil' = translate_expression nil env in + let s_env = + Environment.add hd + @@ Environment.add tl env + in + let%bind s' = translate_expression cons s_env in + let%bind code = ok (seq [ + cond' ; + i_if_cons (seq [ + s' ; + dip (seq [ i_drop ; i_drop ]) ; + ]) nil' + ; + ]) in + return code + ) | E_if_left (c, (l_ntv , l), (r_ntv , r)) -> ( let%bind c' = translate_expression c env in let l_env = Environment.add l_ntv env in diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 514a091df..36298bbf6 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -89,8 +89,8 @@ and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fu 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 @.| %s :: %s -> %a" f match_nil hd tl f match_cons + | Match_list {match_nil ; match_cons = (((hd_name , _), (tl_name , _)), match_cons)} -> + fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd_name tl_name f match_cons | Match_option {match_none ; match_some = (some, match_some)} -> fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f match_some diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index c13200c9a..3f99790fd 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -199,7 +199,7 @@ module Free_variables = struct and matching : type a . (bindings -> a -> bindings) -> bindings -> a matching -> bindings = fun f b m -> match m with | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) - | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c) + | Match_list { match_nil = n ; match_cons = (((hd, _), (tl, _)), c) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c) | Match_option { match_none = n ; match_some = ((opt, _), s) } -> union (f b n) (f (union (singleton opt) b) s) | Match_tuple (lst , a) -> f (union (of_list lst) b) a | Match_variant (lst , _) -> unions @@ List.map (matching_variant_case f b) lst diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index 9e9520e3d..dc74d35b2 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -107,7 +107,7 @@ module Captured_variables = struct let%bind t' = f b t in let%bind fa' = f b fa in ok @@ union t' fa' - | Match_list { match_nil = n ; match_cons = (hd, tl, c) } -> + | Match_list { match_nil = n ; match_cons = (((hd, _), (tl, _)), c) } -> let%bind n' = f b n in let%bind c' = f (union (of_list [hd ; tl]) b) c in ok @@ union n' c' diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index f7ef1595f..06a63e975 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -138,7 +138,7 @@ and 'a matching = } | Match_list of { match_nil : 'a ; - match_cons : name * name * 'a ; + match_cons : ((name * type_value) * (name * type_value)) * 'a ; } | Match_option of { match_none : 'a ; diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 3bb230627..52d87a887 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -80,6 +80,7 @@ and expression' ppf (e:expression') = match e with | E_make_none _ -> fprintf ppf "none" | E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s + | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%s :: %s) -> %a" expression c expression n hd_name tl_name expression cons | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index 26801d227..bbffddbc6 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -69,6 +69,7 @@ and expression' = | E_iterator of (string * ((var_name * type_value) * expression) * expression) | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) + | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) | E_let_in of ((var_name * type_value) * expression * expression) | E_sequence of (expression * expression) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index df2b2cb86..e7030bc1f 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -722,7 +722,7 @@ let main = test_suite "Integration (End to End)" [ test "let-in (mligo)" let_in_mligo ; test "match variant (mligo)" match_variant ; test "match variant 2 (mligo)" match_matej ; - (* test "list matching (mligo)" mligo_list ; *) + test "list matching (mligo)" mligo_list ; (* test "guess the hash mligo" guess_the_hash_mligo ; WIP? *) (* test "failwith mligo" failwith_mligo ; *) (* test "guess string mligo" guess_string_mligo ; WIP? *) diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index f55e1a493..5ac8d1282 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -60,6 +60,7 @@ let i_exec = prim I_EXEC let i_if a b = prim ~children:[seq [a] ; seq[b]] I_IF let i_if_none a b = prim ~children:[seq [a] ; seq[b]] I_IF_NONE +let i_if_cons a b = prim ~children:[seq [a] ; seq[b]] I_IF_CONS let i_if_left a b = prim ~children:[seq [a] ; seq[b]] I_IF_LEFT let i_failwith = prim I_FAILWITH let i_assert_some = i_if_none (seq [i_push_string "ASSERT_SOME" ; i_failwith]) (seq [])