add list pattern matching

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) =

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
     )
 

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

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
 

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

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'

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 ;

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

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)

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? *)

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 [])