'Layout.convert_to_right_comb' and 'Layout.convert_to_left_comb' for sum types

src/bin/expect_tests/michelson_converter.ml

@@ -8,7 +8,7 @@ let bad_contract basename =
 let%expect_test _ =
   run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_no_annotation.mligo") ; "l4"] ;
   [%expect {|
-    ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve declaration order in the converted record, you need to annotate it
+    ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve type declaration order in the converted record, you need to annotate it
 
      If you're not sure how to fix this error, you can
      do one of the following:
@@ -31,24 +31,36 @@ let%expect_test _ =
     * Check the changelog by running 'ligo changelog' |}]
 
 let%expect_test _ =
-  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r3"] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "r3"] ;
   [%expect {|
     ( 2 , ( +3 , "q" ) ) |}] ;
-  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r4"] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "r4"] ;
   [%expect {|
     ( 2 , ( +3 , ( "q" , true ) ) ) |}] ;
-  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l3"] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "l3"] ;
   [%expect {|
     ( ( 2 , +3 ) , "q" ) |}] ;
-  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l4"] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "l4"] ;
   [%expect {|
-    ( ( ( 2 , +3 ) , "q" ) , true ) |}]
+    ( ( ( 2 , +3 ) , "q" ) , true ) |}];
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "str3"] ;
+  [%expect {|
+    M_right(M_left(+3)) |}] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "str4"] ;
+  [%expect {|
+    M_right(M_right(M_left("eq"))) |}] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "stl3"] ;
+  [%expect {|
+    M_left(M_right(+3)) |}] ;
+  run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "stl4"] ;
+  [%expect {|
+    M_left(M_right("eq")) |}]
 
 let%expect_test _ =
-  run_ligo_good [ "dry-run" ; (contract "michelson_converter.mligo") ; "main_r" ; "test_input_pair_r" ; "s"] ;
+  run_ligo_good [ "dry-run" ; (contract "michelson_converter_pair.mligo") ; "main_r" ; "test_input_pair_r" ; "s"] ;
   [%expect {|
     ( LIST_EMPTY() , "eqeq" ) |}] ;
-  run_ligo_good [ "compile-contract" ; (contract "michelson_converter.mligo") ; "main_r" ] ;
+  run_ligo_good [ "compile-contract" ; (contract "michelson_converter_pair.mligo") ; "main_r" ] ;
   [%expect {|
     { parameter (pair (int %one) (pair (nat %two) (pair (string %three) (bool %four)))) ;
       storage string ;
@@ -68,10 +80,10 @@ let%expect_test _ =
              NIL operation ;
              PAIR ;
              DIP { DROP 2 } } } |}];
-  run_ligo_good [ "dry-run" ; (contract "michelson_converter.mligo") ; "main_l" ; "test_input_pair_l" ; "s"] ;
+  run_ligo_good [ "dry-run" ; (contract "michelson_converter_pair.mligo") ; "main_l" ; "test_input_pair_l" ; "s"] ;
   [%expect {|
     ( LIST_EMPTY() , "eqeq" ) |}] ;
-  run_ligo_good [ "compile-contract" ; (contract "michelson_converter.mligo") ; "main_l" ] ;
+  run_ligo_good [ "compile-contract" ; (contract "michelson_converter_pair.mligo") ; "main_l" ] ;
   [%expect {|
     { parameter (pair (pair (pair (int %one) (nat %two)) (string %three)) (bool %four)) ;
       storage string ;

src/passes/2-concrete_to_imperative/cameligo.ml

@@ -307,18 +307,18 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
       ok @@ make_t ~loc @@ T_record m
   | TSum s ->
       let (s,loc) = r_split s in
-      let aux (v:Raw.variant Raw.reg) =
+      let aux i (v:Raw.variant Raw.reg) =
         let args =
           match v.value.arg with
             None -> []
           | Some (_, TProd product) -> npseq_to_list product.value
           | Some (_, t_expr) -> [t_expr] in
         let%bind te = compile_list_type_expression @@ args in
-        ok (v.value.constr.value, te) in
+        ok ((v.value.constr.value,i), te) in
       let%bind lst = bind_list
-        @@ List.map aux
+        @@ List.mapi aux
         @@ npseq_to_list s in
-      let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
+      let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
       ok @@ make_t ~loc @@ T_sum m
   | TStringLiteral _s -> simple_fail "we don't support singleton string type"
 

src/passes/2-concrete_to_imperative/pascaligo.ml

@@ -238,19 +238,19 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
       ok @@ make_t ~loc @@ T_record m
   | TSum s ->
       let (s,loc) = r_split s in
-      let aux (v:Raw.variant Raw.reg) =
+      let aux i (v:Raw.variant Raw.reg) =
         let args =
           match v.value.arg with
             None -> []
           | Some (_, TProd product) -> npseq_to_list product.value
           | Some (_, t_expr) -> [t_expr] in
         let%bind te = compile_list_type_expression @@ args in
-        ok (v.value.constr.value, te)
+        ok ((v.value.constr.value,i), te)
       in
       let%bind lst = bind_list
-        @@ List.map aux
+        @@ List.mapi aux
         @@ npseq_to_list s in
-      let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
+      let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
       ok @@ make_t ~loc @@ T_sum m
   | TStringLiteral _s -> simple_fail "we don't support singleton string type"
 

src/passes/3-self_ast_imperative/helpers.ml

@@ -2,6 +2,13 @@ open Ast_imperative
 open Trace
 open Stage_common.Helpers
 
+let bind_map_cmap_t f map = bind_cmap (
+  CMap.map 
+    (fun ({ctor_type;_} as ctor) -> 
+      let%bind ctor_type = f ctor_type in
+      ok {ctor with ctor_type }) 
+    map)
+
 let bind_map_lmap_t f map = bind_lmap (
   LMap.map 
     (fun ({field_type;_} as field) -> 
@@ -257,7 +264,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
   let return type_content = ok { type_content; location=te.location } in
   match te'.type_content with
   | T_sum temap ->
-    let%bind temap' = bind_map_cmap self temap in
+    let%bind temap' = bind_map_cmap_t self temap in
     return @@ (T_sum temap')
   | T_record temap ->
     let%bind temap' = bind_map_lmap_t self temap in

src/passes/4-imperative_to_sugar/imperative_to_sugar.ml

@@ -135,9 +135,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
     | I.T_sum sum -> 
       let sum = I.CMap.to_kv_list sum in
       let%bind sum = 
-        bind_map_list (fun (k,v) ->
+        bind_map_list (fun (k,({ctor_type = v; ctor_decl_pos ; _}:I.ctor_content)) ->
           let%bind v = compile_type_expression v in
-          let content : O.ctor_content = {ctor_type = v ; michelson_annotation = None} in
+          let content : O.ctor_content = {ctor_type = v ; michelson_annotation = None ; ctor_decl_pos } in
           ok @@ (k,content)
         ) sum
       in
@@ -164,8 +164,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
     | I.T_operator (TC_michelson_or (l,l_ann,r,r_ann)) ->
       let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
       let sum : (O.constructor' * O.ctor_content) list = [
-        (O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann}); 
+        (O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann ; ctor_decl_pos = 0}); 
-        (O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann}); ]
+        (O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann ; ctor_decl_pos = 1}); ]
       in
       return @@ O.T_sum (O.CMap.of_list sum)
     | I.T_operator (TC_michelson_pair (l,l_ann,r,r_ann)) ->
@@ -596,9 +596,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
       let sum = I.CMap.to_kv_list sum in
       let%bind sum = 
         bind_map_list (fun (k,v) ->
-          let {ctor_type;_} : O.ctor_content = v in
+          let {ctor_type;ctor_decl_pos;_} : O.ctor_content = v in
           let%bind v = uncompile_type_expression ctor_type in
-          ok @@ (k,v)
+          ok @@ (k,({ctor_type=v; ctor_decl_pos}: I.ctor_content))
         ) sum
       in
       return @@ I.T_sum (O.CMap.of_list sum)

src/passes/6-sugar_to_core/sugar_to_core.ml

@@ -10,9 +10,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
       let sum = I.CMap.to_kv_list sum in
       let%bind sum = 
         bind_map_list (fun (k,v) ->
-          let {ctor_type ; michelson_annotation} : I.ctor_content = v in
+          let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in
           let%bind ctor_type = idle_type_expression ctor_type in
-          let v' : O.ctor_content = {ctor_type ; michelson_annotation} in
+          let v' : O.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in
           ok @@ (k,v')
         ) sum
       in
@@ -244,9 +244,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
       let sum = I.CMap.to_kv_list sum in
       let%bind sum = 
         bind_map_list (fun (k,v) ->
-          let {ctor_type;michelson_annotation} : O.ctor_content = v in
+          let {ctor_type;michelson_annotation;ctor_decl_pos} : O.ctor_content = v in
           let%bind ctor_type = uncompile_type_expression ctor_type in
-          let v' : I.ctor_content = {ctor_type;michelson_annotation} in
+          let v' : I.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
           ok @@ (k,v')
         ) sum
       in

src/passes/8-typer-new/typer.ml

@@ -133,9 +133,9 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
   | T_sum m ->
     let aux k v prev =
       let%bind prev' = prev in
-      let {ctor_type ; michelson_annotation} : I.ctor_content = v in
+      let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in
       let%bind ctor_type = evaluate_type e ctor_type in
-      ok @@ O.CMap.add (convert_constructor' k) ({ctor_type ; michelson_annotation}:O.ctor_content) prev'
+      ok @@ O.CMap.add (convert_constructor' k) ({ctor_type ; michelson_annotation ; ctor_decl_pos}:O.ctor_content) prev'
     in
     let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
     return (T_sum m)

src/passes/8-typer-new/untyper.ml

@@ -152,10 +152,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
   (* TODO: or should we use t.core if present? *)
   let%bind t = match t.type_content with
   | O.T_sum x ->
-    let aux k ({ctor_type ; michelson_annotation} : O.ctor_content) acc =
+    let aux k ({ctor_type ; michelson_annotation ; ctor_decl_pos} : O.ctor_content) acc =
       let%bind acc = acc in
       let%bind ctor_type = untype_type_expression ctor_type in
-      let v' : I.ctor_content = {ctor_type ; michelson_annotation} in 
+      let v' : I.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in 
       ok @@ I.CMap.add (unconvert_constructor' k) v' acc in
     let%bind x' = O.CMap.fold aux x (ok I.CMap.empty) in
     ok @@ I.T_sum x'

src/passes/8-typer-old/typer.ml

@@ -605,7 +605,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
       let%bind type2 = evaluate_type e type2 in
       return (T_arrow {type1;type2})
   | T_sum m ->
-      let aux k ({ctor_type;michelson_annotation} : I.ctor_content) prev =
+      let aux k ({ctor_type;michelson_annotation;ctor_decl_pos} : I.ctor_content) prev =
         let%bind prev' = prev in
         let%bind ctor_type = evaluate_type e ctor_type in
         let%bind () = match Environment.get_constructor k e with
@@ -614,7 +614,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
               ok ()
             else fail (redundant_constructor e k)
           | None -> ok () in
-        let v' : O.ctor_content = {ctor_type;michelson_annotation} in
+        let v' : O.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in
         ok @@ O.CMap.add (convert_constructor' k) v' prev'
       in
       let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
@@ -665,14 +665,14 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
         let%bind lmap = match c'.type_content with
           | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
           | _ -> fail (michelson_comb_no_record t.location) in
-        let record = Operators.Typer.Converter.convert_type_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
+        let record = Operators.Typer.Converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
         return @@ record
     | TC_michelson_pair_left_comb c ->
         let%bind c' = evaluate_type e c in
         let%bind lmap = match c'.type_content with
           | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap
           | _ -> fail (michelson_comb_no_record t.location) in
-        let record = Operators.Typer.Converter.convert_type_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
+        let record = Operators.Typer.Converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
         return @@ record
   )
 

src/passes/9-self_ast_typed/michelson_layout.ml

@@ -1,34 +1,99 @@
 open Ast_typed
 open Trace
 
-let to_sorted_kv_list lmap =
+let to_sorted_kv_list_l lmap =
   List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;}) -> Int.compare a b) @@
   LMap.to_kv_list lmap
 
+let to_sorted_kv_list_c lmap =
+  List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;}) -> Int.compare a b) @@
+  CMap.to_kv_list lmap
+
 let accessor (record:expression) (path:label) (t:type_expression) =
   { expression_content = E_record_accessor {record; path} ;
     location = Location.generated ;
     type_expression = t ;
-    environment = record.environment}
+    environment = record.environment }
 
-let rec to_left_comb' first prev l conv_map =
+let constructor (constructor:constructor') (element:expression) (t:type_expression) =
+  { expression_content = E_constructor { constructor ; element } ;
+    location = Location.generated ;
+    type_expression = t ;
+    environment = element.environment }
+
+let match_var env (t:type_expression) =
+  { expression_content = E_variable (Var.of_name "x") ;
+    location = Location.generated ;
+    type_expression = t ;
+    environment = env }
+
+let rec to_left_comb_record' first prev l conv_map =
   match l with
   | [] -> conv_map 
   | (label_l, {field_type=t_l}) :: (label_r, {field_type=t_r})::tl when first ->
     let exp_l = accessor prev label_l t_l in
     let exp_r = accessor prev label_r t_r in
     let conv_map' = LMap.add_bindings [ (Label "0" , exp_l) ; (Label "1" , exp_r) ] LMap.empty in
-    to_left_comb' false prev tl conv_map'
+    to_left_comb_record' false prev tl conv_map'
   | (label, {field_type=t})::tl ->
     let conv_map' = LMap.add_bindings [
         (Label "0" , {prev with expression_content = E_record conv_map});
         (Label "1" , accessor prev label t)]
       LMap.empty in
-    to_left_comb' first prev tl conv_map'
+    to_left_comb_record' first prev tl conv_map'
+let to_left_comb_record = to_left_comb_record' true
 
-let to_left_comb = to_left_comb' true
+let rec to_right_comb_variant' (i:int) (e:expression) (dst_lmap:ctor_content constructor_map) (src_kvl:(constructor' * ctor_content) list) : expression list =
+  let rec descend_types lmap i =
+    if i > 0 then
+      let {ctor_type;_} = CMap.find (Constructor "M_right") lmap in
+      match ctor_type.type_content with
+        | T_sum a -> ctor_type::(descend_types a (i-1)) 
+        | _ -> []
+    else [] in
+  let intermediary_types i =  if i = 0 then [] else e.type_expression::(descend_types dst_lmap i) in
+  let rec comb (ctor_type,outer) l =
+    let env' = Environment.add_ez_binder (Var.of_name "x") ctor_type e.environment in
+    match l with
+    | [] -> constructor outer (match_var env' ctor_type) e.type_expression
+    | [t] -> constructor outer (match_var env' ctor_type) t
+    | t::tl -> constructor (Constructor "M_right") (comb (ctor_type,outer) tl) t in
+  ( match src_kvl with
+    | [] -> []
+    | (_,{ctor_type;_})::[] ->
+      let combs_t = intermediary_types (i-1) in
+      [comb (ctor_type,Constructor "M_right") combs_t]
+    | (_,{ctor_type;_})::tl ->
+      let combs_t = intermediary_types i in
+      (comb (ctor_type,Constructor "M_left") combs_t) :: to_right_comb_variant' (i+1) e dst_lmap tl )
+let to_right_comb_variant = to_right_comb_variant' 0
 
-let rec to_right_comb
+let rec to_left_comb_variant' (i:int) (e:expression) (dst_lmap:ctor_content constructor_map) (src_kvl:(constructor' * ctor_content) list) : expression list =
+  let rec descend_types lmap i =
+    if i > 0 then
+      let {ctor_type;_} = CMap.find (Constructor "M_left") lmap in
+      match ctor_type.type_content with
+        | T_sum a -> ctor_type::(descend_types a (i-1)) 
+        | _ -> []
+    else [] in
+  let intermediary_types i =  if i = 0 then [] else e.type_expression::(descend_types dst_lmap i) in
+  let rec comb (ctor_type,outer) l =
+    let env' = Environment.add_ez_binder (Var.of_name "x") ctor_type e.environment in
+    match l with
+    | [] -> constructor outer (match_var env' ctor_type) e.type_expression
+    | [t] -> constructor outer (match_var env' ctor_type) t
+    | t::tl -> constructor (Constructor "M_left") (comb (ctor_type,outer) tl) t in
+  ( match src_kvl with
+    | [] -> []
+    | (_,{ctor_type;_})::[] ->
+      let combs_t = intermediary_types (i-1) in
+      [comb (ctor_type,Constructor "M_left") combs_t]
+    | (_,{ctor_type;_})::tl ->
+      let combs_t = intermediary_types i in
+      (comb (ctor_type,Constructor "M_right") combs_t) :: to_left_comb_variant' (i+1) e dst_lmap tl )
+let to_left_comb_variant a b c = List.rev @@ to_left_comb_variant' 0 a b (List.rev c)
+
+let rec to_right_comb_record
     (prev:expression)
     (l:(label * field_content) list)
     (conv_map: expression label_map) : expression label_map =
@@ -44,7 +109,7 @@ let rec to_right_comb
                 type_expression = field_type ;
                 environment = prev.environment } in
     let conv_map' = LMap.add (Label "0") exp conv_map in
-    LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb prev tl conv_map')}) conv_map'
+    LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map'
 
 let rec from_right_comb
     (prev:expression) 
@@ -79,7 +144,6 @@ let rec from_left_comb'
     from_left_comb' next src_lmap' tl conv_map'
   | [(label,_)] -> LMap.add label prev conv_map
   | [] -> conv_map
-
 let from_left_comb prev src_lmap dst_kvl conv_map =
   from_left_comb' prev src_lmap (List.rev dst_kvl) conv_map
 
@@ -90,26 +154,56 @@ let from_left_comb prev src_lmap dst_kvl conv_map =
 let peephole_expression : expression -> expression result = fun e ->
   let return expression_content = ok { e with expression_content } in
   match e.expression_content with
-  | E_constant {cons_name= (C_CONVERT_TO_LEFT_COMB);
+  | E_constant {cons_name= (C_CONVERT_TO_LEFT_COMB);arguments= [ to_convert ] } -> (
-                arguments= [ to_convert ] } ->
+    match to_convert.type_expression.type_content with
-    let%bind src_lmap = get_t_record to_convert.type_expression in
+      | T_record src_lmap ->
-    let src_kvl = to_sorted_kv_list src_lmap in
+        let src_kvl = to_sorted_kv_list_l src_lmap in
-    return @@ E_record (to_left_comb to_convert src_kvl LMap.empty)
+        return @@ E_record (to_left_comb_record to_convert src_kvl LMap.empty)
-  | E_constant {cons_name= (C_CONVERT_TO_RIGHT_COMB);
+      | T_sum src_cmap ->
-                arguments= [ to_convert ] } ->
+        let%bind dst_cmap = get_t_sum e.type_expression in
-    let%bind src_lmap = get_t_record to_convert.type_expression in
+        let src_kvl = to_sorted_kv_list_c src_cmap in
-    let src_kvl = to_sorted_kv_list src_lmap in
+        let bodies = to_left_comb_variant e dst_cmap src_kvl in
-    return @@ E_record (to_right_comb to_convert src_kvl LMap.empty)
+        let to_cases ((constructor,{ctor_type=_;_}),body) =
+          let pattern = (Var.of_name "x") in
+          {constructor ; pattern ; body }
+        in
+        let cases = Match_variant {
+          cases = List.map to_cases @@ (List.combine src_kvl bodies) ;
+          tv = to_convert.type_expression }
+        in
+        return @@ E_matching {matchee = to_convert ; cases}
+      | _ -> return e.expression_content
+  )
+  | E_constant {cons_name= (C_CONVERT_TO_RIGHT_COMB);arguments= [ to_convert ] } -> (
+    match to_convert.type_expression.type_content with
+      | T_record src_lmap ->
+        let src_kvl = to_sorted_kv_list_l src_lmap in
+        return @@ E_record (to_right_comb_record to_convert src_kvl LMap.empty)
+      | T_sum src_cmap ->
+        let%bind dst_cmap = get_t_sum e.type_expression in
+        let src_kvl = to_sorted_kv_list_c src_cmap in
+        let bodies = to_right_comb_variant e dst_cmap src_kvl in
+        let to_cases ((constructor,{ctor_type=_;_}),body) =
+          let pattern = (Var.of_name "x") in
+          {constructor ; pattern ; body }
+        in
+        let cases = Match_variant {
+          cases = List.map to_cases @@ (List.combine src_kvl bodies) ;
+          tv = to_convert.type_expression }
+        in
+        return @@ E_matching {matchee = to_convert ; cases}
+      | _ -> return e.expression_content
+  )
   | E_constant {cons_name= (C_CONVERT_FROM_RIGHT_COMB);
                 arguments= [ to_convert ] } ->
     let%bind dst_lmap = get_t_record e.type_expression in
     let%bind src_lmap = get_t_record to_convert.type_expression in
-    let dst_kvl = to_sorted_kv_list dst_lmap in
+    let dst_kvl = to_sorted_kv_list_l dst_lmap in
     return @@ E_record (from_right_comb to_convert src_lmap dst_kvl LMap.empty)
   | E_constant {cons_name= (C_CONVERT_FROM_LEFT_COMB);
                 arguments= [ to_convert ] } ->
     let%bind dst_lmap = get_t_record e.type_expression in
     let%bind src_lmap = get_t_record to_convert.type_expression in
-    let dst_kvl = to_sorted_kv_list dst_lmap in
+    let dst_kvl = to_sorted_kv_list_l dst_lmap in
     return @@ E_record (from_left_comb to_convert src_lmap dst_kvl LMap.empty)
   | _ as e -> return e

src/passes/operators/helpers.ml

@@ -143,21 +143,41 @@ module Typer = struct
         (List.length kvl >=2) in
       let all_undefined = List.for_all (fun (_,{field_decl_pos;_}) -> field_decl_pos = 0) kvl in
       let%bind () = Assert.assert_true_err
-        (simple_error "can't retrieve declaration order in the converted record, you need to annotate it")
+        (simple_error "can't retrieve type declaration order in the converted record, you need to annotate it")
+        (not all_undefined) in
+      ok ()
+
+    let variant_checks kvl =
+      let%bind () = Assert.assert_true_err
+        (simple_error "converted variant must have at least two elements")
+        (List.length kvl >=2) in
+      let all_undefined = List.for_all (fun (_,{ctor_decl_pos;_}) -> ctor_decl_pos = 0) kvl in
+      let%bind () = Assert.assert_true_err
+        (simple_error "can't retrieve type declaration order in the converted variant, you need to annotate it")
         (not all_undefined) in
       ok ()
     
     let annotate_field (field:field_content) (ann:string) : field_content =
       {field with michelson_annotation=Some ann}
 
-    let comb (t:type_content) : field_content =
+    let annotate_ctor (ctor:ctor_content) (ann:string) : ctor_content =
+      {ctor with michelson_annotation=Some ann}
+
+    let comb_pair (t:type_content) : field_content =
       let field_type = {
         type_content = t ;
         type_meta = None ;
         location = Location.generated ; } in
       {field_type ; michelson_annotation = Some "" ; field_decl_pos = 0}
 
-    let rec to_right_comb_t l new_map =
+    let comb_ctor (t:type_content) : ctor_content =
+      let ctor_type = {
+        type_content = t ;
+        type_meta = None ;
+        location = Location.generated ; } in
+      {ctor_type ; michelson_annotation = Some "" ; ctor_decl_pos = 0}
+
+    let rec to_right_comb_pair l new_map =
       match l with
       | [] -> new_map
       | [ (Label ann_l, field_content_l) ; (Label ann_r, field_content_r) ] ->
@@ -166,65 +186,99 @@ module Typer = struct
           (Label "1" , annotate_field field_content_r ann_r) ] new_map
       | (Label ann, field)::tl ->
         let new_map' = LMap.add (Label "0") (annotate_field field ann) new_map in
-        LMap.add (Label "1") (comb (T_record (to_right_comb_t tl new_map'))) new_map'
+        LMap.add (Label "1") (comb_pair (T_record (to_right_comb_pair tl new_map'))) new_map'
 
-    let rec to_left_comb_t' first l new_map =
+    let rec to_right_comb_variant l new_map =
+      match l with
+      | [] -> new_map
+      | [ (Constructor ann_l, field_content_l) ; (Constructor ann_r, field_content_r) ] ->
+        CMap.add_bindings [
+          (Constructor "M_left" , annotate_ctor field_content_l ann_l) ;
+          (Constructor "M_right" , annotate_ctor field_content_r ann_r) ] new_map
+      | (Constructor ann, field)::tl ->
+        let new_map' = CMap.add (Constructor "M_left") (annotate_ctor field ann) new_map in
+        CMap.add (Constructor "M_right") (comb_ctor (T_sum (to_right_comb_variant tl new_map'))) new_map'
+
+    let rec to_left_comb_pair' first l new_map =
       match l with
       | [] -> new_map
       | (Label ann_l, field_content_l) :: (Label ann_r, field_content_r) ::tl when first ->
         let new_map' = LMap.add_bindings [
           (Label "0" , annotate_field field_content_l ann_l) ;
           (Label "1" , annotate_field field_content_r ann_r) ] LMap.empty in
-        to_left_comb_t' false tl new_map'
+        to_left_comb_pair' false tl new_map'
       | (Label ann, field)::tl ->
         let new_map' = LMap.add_bindings [
-          (Label "0" , comb (T_record new_map)) ;
+          (Label "0" , comb_pair (T_record new_map)) ;
           (Label "1" , annotate_field field ann ) ;] LMap.empty in
-        to_left_comb_t' first tl new_map'
+        to_left_comb_pair' first tl new_map'
-    let to_left_comb_t = to_left_comb_t' true
+    let to_left_comb_pair = to_left_comb_pair' true
 
-    let convert_type_to_right_comb l =
+    let rec to_left_comb_variant' first l new_map =
-      let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
+      match l with
-      T_record (to_right_comb_t l' LMap.empty)
+      | [] -> new_map
+      | (Constructor ann_l, ctor_content_l) :: (Constructor ann_r, ctor_content_r) ::tl when first ->
+        let new_map' = CMap.add_bindings [
+          (Constructor "M_left" , annotate_ctor ctor_content_l ann_l) ;
+          (Constructor "M_right" , annotate_ctor ctor_content_r ann_r) ] CMap.empty in
+        to_left_comb_variant' false tl new_map'
+      | (Constructor ann, ctor)::tl ->
+        let new_map' = CMap.add_bindings [
+          (Constructor "M_left" , comb_ctor (T_sum new_map)) ;
+          (Constructor "M_right" , annotate_ctor ctor ann ) ;] CMap.empty in
+        to_left_comb_variant' first tl new_map'
+    let to_left_comb_variant = to_left_comb_variant' true
 
-    let convert_type_to_left_comb l =
+    let rec from_right_comb_pair (l:field_content label_map) (size:int) : (field_content list) result =
-      let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
-      T_record (to_left_comb_t l' LMap.empty)
-
-    let rec from_right_comb (l:field_content label_map) (size:int) : (field_content list) result =
       let l' = List.rev @@ LMap.to_kv_list l in
       match l' , size with
       | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
       | [ (_,l) ; (_,{field_type=tr;_}) ], _ ->
         let%bind comb_lmap = get_t_record tr in
-        let%bind next = from_right_comb comb_lmap (size-1) in
+        let%bind next = from_right_comb_pair comb_lmap (size-1) in
         ok (l :: next)
       | _ -> simple_fail "Could not convert michelson_pair_right_comb pair to a record"
 
-    let rec from_left_comb (l:field_content label_map) (size:int) : (field_content list) result =
+    let rec from_left_comb_pair (l:field_content label_map) (size:int) : (field_content list) result =
       let l' = List.rev @@ LMap.to_kv_list l in
       match l' , size with
       | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ]
       | [ (_,{field_type=tl;_}) ; (_,r) ], _ ->
         let%bind comb_lmap = get_t_record tl in
-        let%bind next = from_left_comb comb_lmap (size-1) in
+        let%bind next = from_left_comb_pair comb_lmap (size-1) in
         ok (List.append next [r])
       | _ -> simple_fail "Could not convert michelson_pair_left_comb pair to a record"
 
-    let convert_from_right_comb (src: field_content label_map) (dst: field_content label_map) : type_content result =
+    let convert_pair_to_right_comb l =
-      let%bind fields = from_right_comb src (LMap.cardinal dst) in
+      let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
+      T_record (to_right_comb_pair l' LMap.empty)
+
+    let convert_pair_to_left_comb l =
+      let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in
+      T_record (to_left_comb_pair l' LMap.empty)
+    
+    let convert_pair_from_right_comb (src: field_content label_map) (dst: field_content label_map) : type_content result =
+      let%bind fields = from_right_comb_pair src (LMap.cardinal dst) in
       let labels = List.map (fun (l,_) -> l) @@
         List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@
         LMap.to_kv_list dst in
       ok @@ (T_record (LMap.of_list @@ List.combine labels fields))
 
-    let convert_from_left_comb (src: field_content label_map) (dst: field_content label_map) : type_content result =
+    let convert_pair_from_left_comb (src: field_content label_map) (dst: field_content label_map) : type_content result =
-      let%bind fields = from_left_comb src (LMap.cardinal dst) in
+      let%bind fields = from_left_comb_pair src (LMap.cardinal dst) in
       let labels = List.map (fun (l,_) -> l) @@
         List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@
         LMap.to_kv_list dst in
       ok @@ (T_record (LMap.of_list @@ List.combine labels fields))
 
+    let convert_variant_to_right_comb l =
+      let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
+      T_sum (to_right_comb_variant l' CMap.empty)
+
+    let convert_variant_to_left_comb l =
+      let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in
+      T_sum (to_left_comb_variant l' CMap.empty)
+
   end
 
 end

src/passes/operators/helpers.mli

@@ -58,10 +58,15 @@ module Typer : sig
     open Ast_typed
 
     val record_checks : (label * field_content) list -> unit result
-    val convert_type_to_right_comb : (label * field_content) list -> type_content
+    val variant_checks : (constructor' * ctor_content) list -> unit result
-    val convert_type_to_left_comb : (label * field_content) list -> type_content
+
-    val convert_from_right_comb : field_content label_map -> field_content label_map -> type_content result
+    val convert_pair_to_right_comb : (label * field_content) list -> type_content
-    val convert_from_left_comb : field_content label_map -> field_content label_map -> type_content result
+    val convert_pair_to_left_comb : (label * field_content) list -> type_content
+    val convert_pair_from_right_comb : field_content label_map -> field_content label_map -> type_content result
+    val convert_pair_from_left_comb : field_content label_map -> field_content label_map -> type_content result
+
+    val convert_variant_to_right_comb : (constructor' * ctor_content) list -> type_content
+    val convert_variant_to_left_comb : (constructor' * ctor_content) list -> type_content
 
   end
 end

src/passes/operators/operators.ml

@@ -1168,32 +1168,46 @@ module Typer = struct
     let%bind () = assert_eq_1 hd elt in
     ok tl
 
-  let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun record ->
+  let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun t ->
-    let%bind lmap = get_t_record record in
+    match t.type_content with
-    let kvl =  LMap.to_kv_list lmap in
+      | T_record lmap ->
-    let%bind () = Converter.record_checks kvl in
+        let kvl = LMap.to_kv_list lmap in
-    let pair = Converter.convert_type_to_right_comb kvl in
+        let%bind () = Converter.record_checks kvl in
-    ok {record with type_content = pair}
+        let pair = Converter.convert_pair_to_right_comb kvl in
+        ok {t with type_content = pair}
+      | T_sum cmap ->
+        let kvl = CMap.to_kv_list cmap in
+        let%bind () = Converter.variant_checks kvl in
+        let michelson_or = Converter.convert_variant_to_right_comb kvl in
+        ok {t with type_content = michelson_or}
+      | _ -> simple_fail "converter can only be used on record or variants"
 
-  let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun record ->
+  let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun t ->
-    let%bind lmap = get_t_record record in
+    match t.type_content with
-    let kvl =  LMap.to_kv_list lmap in
+      | T_record lmap ->
-    let%bind () = Converter.record_checks kvl in
+        let kvl =  LMap.to_kv_list lmap in
-    let pair = Converter.convert_type_to_left_comb kvl in
+        let%bind () = Converter.record_checks kvl in
-    ok {record with type_content = pair}
+        let pair = Converter.convert_pair_to_left_comb kvl in
+        ok {t with type_content = pair}
+      | T_sum cmap ->
+        let kvl = CMap.to_kv_list cmap in
+        let%bind () = Converter.variant_checks kvl in
+        let michelson_or = Converter.convert_variant_to_left_comb kvl in
+        ok {t with type_content = michelson_or}
+      | _ -> simple_fail "converter can only be used on record or variants"
 
   let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun pair opt ->
     let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in
     let%bind dst_lmap = get_t_record dst_t in
     let%bind src_lmap = get_t_record pair in
-    let%bind record = Converter.convert_from_right_comb src_lmap dst_lmap in
+    let%bind record = Converter.convert_pair_from_right_comb src_lmap dst_lmap in
     ok {pair with type_content = record}
 
   let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun pair opt ->
     let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in
     let%bind dst_lmap = get_t_record dst_t in
     let%bind src_lmap = get_t_record pair in
-    let%bind record = Converter.convert_from_left_comb src_lmap dst_lmap in
+    let%bind record = Converter.convert_pair_from_left_comb src_lmap dst_lmap in
     ok {pair with type_content = record}
   
   let constant_typers c : typer result = match c with

src/passes/operators/operators.mli

@@ -176,8 +176,8 @@ module Typer : sig
     open Ast_typed
 
     val record_checks : (label * field_content) list -> unit result
-    val convert_type_to_right_comb : (label * field_content) list -> type_content
+    val convert_pair_to_right_comb : (label * field_content) list -> type_content
-    val convert_type_to_left_comb : (label * field_content) list -> type_content
+    val convert_pair_to_left_comb : (label * field_content) list -> type_content
 
   end
 end

src/stages/1-ast_imperative/PP.ml

@@ -8,7 +8,7 @@ include Stage_common.PP
 let cmap_sep value sep ppf m =
   let lst = CMap.to_kv_list m in
   let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
-  let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
+  let new_pp ppf (k, ({ctor_type=v;_}:ctor_content)) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
   fprintf ppf "%a" (list_sep new_pp sep) lst
 
 let cmap_sep_d x = cmap_sep x (tag " ,@ ")
@@ -16,7 +16,7 @@ let cmap_sep_d x = cmap_sep x (tag " ,@ ")
 let record_sep_t value sep ppf (m : 'a label_map) =
   let lst = LMap.to_kv_list m in
   let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
-  let new_pp ppf (k, {field_type=v;_}) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
+  let new_pp ppf (k, ({field_type=v;_}:field_content)) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
   fprintf ppf "%a" (list_sep new_pp sep) lst
 
 let record_sep value sep ppf (m : 'a label_map) =

src/stages/1-ast_imperative/combinators.ml

@@ -40,7 +40,7 @@ let t_variable ?loc n     : type_expression = make_t ?loc @@ T_variable (Var.of_
 let t_record_ez ?loc lst =
   let lst = List.mapi (fun i (k, v) -> (Label k, {field_type=v;field_decl_pos=i})) lst in
   let m = LMap.of_list lst in
-  make_t ?loc @@ T_record m
+  make_t ?loc @@ T_record (m:field_content label_map)
 let t_record ?loc m  : type_expression =
   let lst = Map.String.to_kv_list m in
   t_record_ez ?loc lst
@@ -49,9 +49,9 @@ let t_tuple ?loc lst    : type_expression = make_t ?loc @@ T_tuple lst
 let t_pair ?loc (a , b) : type_expression = t_tuple ?loc [a; b]
 
 let ez_t_sum ?loc (lst:(string * type_expression) list) : type_expression =
-  let aux prev (k, v) = CMap.add (Constructor k) v prev in
+  let aux (prev,i) (k, v) = (CMap.add (Constructor k) {ctor_type=v;ctor_decl_pos=i} prev, i+1) in
-  let map = List.fold_left aux CMap.empty lst in
+  let (map,_) = List.fold_left aux (CMap.empty,0) lst in
-  make_t ?loc @@ T_sum map
+  make_t ?loc @@ T_sum (map: ctor_content constructor_map)
 let t_sum ?loc m : type_expression =
   let lst = Map.String.to_kv_list m in
   ez_t_sum ?loc lst

src/stages/1-ast_imperative/types.ml

@@ -5,7 +5,7 @@ module Location = Simple_utils.Location
 include Stage_common.Types
 
 type type_content =
-  | T_sum of type_expression constructor_map
+  | T_sum of ctor_content constructor_map
   | T_record of field_content label_map
   | T_tuple  of type_expression list
   | T_arrow of arrow
@@ -15,7 +15,9 @@ type type_content =
 
 and arrow = {type1: type_expression; type2: type_expression}
 
-and field_content = {field_type :type_expression ; field_decl_pos : int} 
+and field_content = {field_type : type_expression ; field_decl_pos : int} 
+
+and ctor_content = {ctor_type : type_expression ; ctor_decl_pos : int} 
 
 and michelson_prct_annotation = string
 

src/stages/2-ast_sugar/types.ml

@@ -19,7 +19,7 @@ type type_content =
 
 and arrow = {type1: type_expression; type2: type_expression}
 
-and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option}
+and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int}
 
 and field_content = {field_type : type_expression ; michelson_annotation : string option ; field_decl_pos : int}
 

src/stages/4-ast_typed/types.ml

@@ -40,6 +40,7 @@ and annot_option = string option
 and ctor_content = {
     ctor_type : type_expression;
     michelson_annotation : annot_option;
+    ctor_decl_pos : int;
 }
 
 and field_content = {

src/stages/common/types.ml

@@ -47,7 +47,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
 
   and arrow = {type1: type_expression; type2: type_expression}
   
-  and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option}
+  and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int}
 
   and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int}
 

src/test/contracts/michelson_converter_or.mligo

@@ -0,0 +1,21 @@
+type st4 =
+  | Foo4 of int
+  | Bar4 of nat
+  | Baz4 of string
+  | Boz4 of bool
+
+type st3 =
+  | Foo3 of int
+  | Bar3 of nat
+  | Baz3 of string
+
+(** convert_to **)
+
+let vst3 = Bar3 3n
+let vst4 = Baz4 "eq"
+
+let str3 = Layout.convert_to_right_comb (vst3:st3)
+let str4 = Layout.convert_to_right_comb (vst4:st4)
+
+let stl3 = Layout.convert_to_left_comb (vst3:st3)
+let stl4 = Layout.convert_to_left_comb (vst4:st4)

src/test/contracts/michelson_converter_pair.mligo

@@ -1,12 +1,12 @@
 type t3 = { foo : int ; bar : nat ;  baz : string}
 type t4 = { one: int ; two : nat ; three : string ; four : bool}
 
-
 (*convert to*)
 
 let v3 = { foo = 2 ; bar = 3n ; baz = "q" }
-let r3 = Layout.convert_to_right_comb (v3:t3)
 let v4 = { one = 2 ; two = 3n ; three = "q" ; four = true }
+
+let r3 = Layout.convert_to_right_comb (v3:t3)
 let r4 = Layout.convert_to_right_comb (v4:t4)
 
 let l3 = Layout.convert_to_left_comb (v3:t3)
@@ -17,13 +17,13 @@ let l4 = Layout.convert_to_left_comb (v4:t4)
 let s = "eq"
 let test_input_pair_r = (1,(2n,(s,true)))
 let test_input_pair_l = (((1,2n), s), true)
-type param_r = t4 michelson_pair_right_comb
-type param_l = t4 michelson_pair_left_comb
 
+type param_r = t4 michelson_pair_right_comb
 let main_r (p, s : param_r * string) : (operation list * string) =
   let r4 : t4 = Layout.convert_from_right_comb p in
   ([] : operation list),  r4.three ^ p.1.1.0
 
+type param_l = t4 michelson_pair_left_comb
 let main_l (p, s : param_l * string) : (operation list * string) =
   let r4 : t4 = Layout.convert_from_left_comb p in
   ([] : operation list),  r4.three ^ p.0.1

src/test/typer_tests.ml

@@ -56,8 +56,8 @@ module TestExpressions = struct
 
   let constructor () : unit result =
     let variant_foo_bar : (Typed.constructor' * Typed.ctor_content) list = [
-        (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None});
+        (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None ; ctor_decl_pos = 0});
-        (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None}) ]
+        (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ]
     in test_expression
       ~env:(E.env_sum_type variant_foo_bar)
       I.(e_constructor "foo" (e_int (Z.of_int 32)))