Change type_operator

src/bin/expect_tests/contract_tests.ml

@@ -1321,7 +1321,7 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; contract "bad_type_operator.ligo" ; "main" ] ;
   [%expect {|
-    ligo: bad type operator (TO_Map (unit,unit)):
+    ligo: bad type operator (type_operator: Map (binding)):
 
      If you're not sure how to fix this error, you can
      do one of the following:

src/passes/2-concrete_to_imperative/cameligo.ml

@@ -286,7 +286,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
           let%bind cst =
           trace_option (unknown_predefined_type name) @@
           type_operators name.value in
-          t_operator ~loc cst lst' )
+          ok @@ t_operator ~loc cst lst' )
     )
   | TProd p -> (
       let%bind tpl = compile_list_type_expression  @@ npseq_to_list p.value in

src/passes/2-concrete_to_imperative/pascaligo.ml

@@ -213,7 +213,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
           let%bind cst =
             trace_option (unknown_predefined_type name) @@
             type_operators name.value in
-          t_operator ~loc cst lst)
+          ok @@ t_operator ~loc cst lst)
   | TProd p ->
       let%bind tpl = compile_list_type_expression
     @@ npseq_to_list p.value in

src/passes/3-self_ast_imperative/helpers.ml

@@ -276,6 +276,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
     let%bind type1' = self type1 in
     let%bind type2' = self type2 in
     return @@ (T_arrow {type1=type1' ; type2=type2'})
+  | T_annoted (ty, str) -> 
+    let%bind ty = self ty in
+    return @@ T_annoted (ty, str)
   | T_operator _
   | T_variable _ | T_constant _ -> ok te'
 

src/passes/4-imperative_to_sugar/imperative_to_sugar.ml

@@ -161,58 +161,28 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
       return @@ T_arrow {type1;type2}
     | I.T_variable type_variable -> return @@ T_variable type_variable 
     | I.T_constant type_constant -> return @@ T_constant type_constant
-    | I.T_operator (TC_michelson_or (l,l_ann,r,r_ann)) ->
+    | I.T_operator (TC_michelson_or, [l;r]) ->
+      let%bind (l, l_ann) = I.get_t_annoted l in
+      let%bind (r, r_ann) = I.get_t_annoted r in
       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 ; ctor_decl_pos = 0}); 
         (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)) ->
+    | I.T_operator (TC_michelson_pair, [l;r]) ->
+      let%bind (l, l_ann) = I.get_t_annoted l in
+      let%bind (r, r_ann) = I.get_t_annoted r in
       let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in
       let sum : (O.label * O.field_content) list = [
         (O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann ; field_decl_pos = 0}); 
         (O.Label "1", {field_type = r ; michelson_annotation = Some r_ann ; field_decl_pos = 0}); ]
       in
       return @@ O.T_record (O.LMap.of_list sum)
-    | I.T_operator type_operator ->
+    | I.T_operator (type_operator, lst) ->
-      let%bind type_operator = compile_type_operator type_operator in
+      let%bind lst = bind_map_list compile_type_expression lst in
-      return @@ T_operator type_operator
+      return @@ T_operator (type_operator, lst)
-
+    | I.T_annoted (ty, _) -> compile_type_expression ty
-and compile_type_operator : I.type_operator -> O.type_operator result =
-  fun t_o ->
-  match t_o with
-    | TC_contract c -> 
-      let%bind c = compile_type_expression c in
-      ok @@ O.TC_contract c
-    | TC_option o ->
-      let%bind o = compile_type_expression o in
-      ok @@ O.TC_option o
-    | TC_list l ->
-      let%bind l = compile_type_expression l in
-      ok @@ O.TC_list l
-    | TC_set s ->
-      let%bind s = compile_type_expression s in
-      ok @@ O.TC_set s
-    | TC_map (k,v) ->
-      let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
-      ok @@ O.TC_map (k,v)
-    | TC_big_map (k,v) ->
-      let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
-      ok @@ O.TC_big_map (k,v)
-    | TC_michelson_or _ | TC_michelson_pair _ -> fail @@ Errors.corner_case __LOC__
-    | TC_michelson_pair_right_comb c ->
-      let%bind c = compile_type_expression c in
-      ok @@ O.TC_michelson_pair_right_comb c
-    | TC_michelson_pair_left_comb c ->
-      let%bind c = compile_type_expression c in
-      ok @@ O.TC_michelson_pair_left_comb c
-    | TC_michelson_or_right_comb c ->
-      let%bind c = compile_type_expression c in
-      ok @@ O.TC_michelson_or_right_comb c
-    | TC_michelson_or_left_comb c ->
-      let%bind c = compile_type_expression c in
-      ok @@ O.TC_michelson_or_left_comb c
 
 let rec compile_expression : I.expression -> O.expression result =
   fun e ->
@@ -627,43 +597,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
       return @@ T_arrow {type1;type2}
     | O.T_variable type_variable -> return @@ T_variable type_variable 
     | O.T_constant type_constant -> return @@ T_constant type_constant
-    | O.T_operator type_operator ->
+    | O.T_operator (type_operator, lst) ->
-      let%bind type_operator = uncompile_type_operator type_operator in
+      let%bind lst = bind_map_list uncompile_type_expression lst in
-      return @@ T_operator type_operator
+      return @@ T_operator (type_operator, lst)
-
-and uncompile_type_operator : O.type_operator -> I.type_operator result =
-  fun t_o ->
-  match t_o with
-    | TC_contract c -> 
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_contract c
-    | TC_option o ->
-      let%bind o = uncompile_type_expression o in
-      ok @@ I.TC_option o
-    | TC_list l ->
-      let%bind l = uncompile_type_expression l in
-      ok @@ I.TC_list l
-    | TC_set s ->
-      let%bind s = uncompile_type_expression s in
-      ok @@ I.TC_set s
-    | TC_map (k,v) ->
-      let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
-      ok @@ I.TC_map (k,v)
-    | TC_big_map (k,v) ->
-      let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
-      ok @@ I.TC_big_map (k,v)
-    | TC_michelson_pair_right_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_pair_right_comb c
-    | TC_michelson_pair_left_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_pair_left_comb c
-    | TC_michelson_or_right_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_or_right_comb c
-    | TC_michelson_or_left_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_or_left_comb c
 
 let rec uncompile_expression' : O.expression -> I.expression result =
   fun e ->

src/passes/6-sugar_to_core/sugar_to_core.ml

@@ -41,43 +41,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
       return @@ T_arrow {type1;type2}
     | I.T_variable type_variable -> return @@ T_variable type_variable 
     | I.T_constant type_constant -> return @@ T_constant type_constant
-    | I.T_operator type_operator ->
+    | I.T_operator (type_operator, lst) ->
-      let%bind type_operator = idle_type_operator type_operator in
+      let%bind lst = bind_map_list idle_type_expression lst in
-      return @@ T_operator type_operator
+      return @@ T_operator (type_operator, lst)
-
-and idle_type_operator : I.type_operator -> O.type_operator result =
-  fun t_o ->
-  match t_o with
-    | TC_contract c -> 
-      let%bind c = idle_type_expression c in
-      ok @@ O.TC_contract c
-    | TC_option o ->
-      let%bind o = idle_type_expression o in
-      ok @@ O.TC_option o
-    | TC_list l ->
-      let%bind l = idle_type_expression l in
-      ok @@ O.TC_list l
-    | TC_set s ->
-      let%bind s = idle_type_expression s in
-      ok @@ O.TC_set s
-    | TC_map (k,v) ->
-      let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
-      ok @@ O.TC_map (k,v)
-    | TC_big_map (k,v) ->
-      let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
-      ok @@ O.TC_big_map (k,v)
-    | TC_michelson_pair_right_comb c ->
-      let%bind c = idle_type_expression c in
-      ok @@ O.TC_michelson_pair_right_comb c
-    | TC_michelson_pair_left_comb c ->
-      let%bind c = idle_type_expression c in
-      ok @@ O.TC_michelson_pair_left_comb c
-    | TC_michelson_or_right_comb c ->
-      let%bind c = idle_type_expression c in
-      ok @@ O.TC_michelson_or_right_comb c
-    | TC_michelson_or_left_comb c ->
-      let%bind c = idle_type_expression c in
-      ok @@ O.TC_michelson_or_left_comb c
 
 let rec compile_expression : I.expression -> O.expression result =
   fun e ->
@@ -274,44 +240,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
       return @@ T_arrow {type1;type2}
     | O.T_variable type_variable -> return @@ T_variable type_variable 
     | O.T_constant type_constant -> return @@ T_constant type_constant
-    | O.T_operator type_operator ->
+    | O.T_operator (type_operator, lst) ->
-      let%bind type_operator = uncompile_type_operator type_operator in
+      let%bind lst = bind_map_list uncompile_type_expression lst in
-      return @@ T_operator type_operator
+      return @@ T_operator (type_operator, lst)
-
-and uncompile_type_operator : O.type_operator -> I.type_operator result =
-  fun t_o ->
-  match t_o with
-    | TC_contract c -> 
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_contract c
-    | TC_option o ->
-      let%bind o = uncompile_type_expression o in
-      ok @@ I.TC_option o
-    | TC_list l ->
-      let%bind l = uncompile_type_expression l in
-      ok @@ I.TC_list l
-    | TC_set s ->
-      let%bind s = uncompile_type_expression s in
-      ok @@ I.TC_set s
-    | TC_map (k,v) ->
-      let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
-      ok @@ I.TC_map (k,v)
-    | TC_big_map (k,v) ->
-      let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
-      ok @@ I.TC_big_map (k,v)
-    | TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled"
-    | TC_michelson_pair_right_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_pair_right_comb c
-    | TC_michelson_pair_left_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_pair_left_comb c
-    | TC_michelson_or_right_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_or_right_comb c
-    | TC_michelson_or_left_comb c ->
-      let%bind c = uncompile_type_expression c in
-      ok @@ I.TC_michelson_or_left_comb c
 
 let rec uncompile_expression : O.expression -> I.expression result =
   fun e ->

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

@@ -150,3 +150,8 @@ let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_express
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
   error ~data title message ()
+
+let bad_type_operator type_op =
+  let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
+  let message () = "" in
+  error title message

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

@@ -156,36 +156,37 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
     ok tv
   | T_constant cst ->
       return (T_constant (convert_type_constant cst))
-  | T_operator opt ->
+  | T_operator (op, lst) ->
-      let%bind opt = match opt with
+      let%bind opt = match op,lst with
-        | TC_set s ->
+        | TC_set, [s] ->
             let%bind s = evaluate_type e s in
             ok @@ O.TC_set (s)
-        | TC_option o ->
+        | TC_option, [o] ->
             let%bind o = evaluate_type e o in
             ok @@ O.TC_option (o)
-        | TC_list l ->
+        | TC_list, [l] ->
             let%bind l = evaluate_type e l in
             ok @@ O.TC_list (l)
-        | TC_map (k,v) ->
+        | TC_map, [k;v] ->
             let%bind k = evaluate_type e k in
             let%bind v = evaluate_type e v in
             ok @@ O.TC_map {k;v}
-        | TC_big_map (k,v) ->
+        | TC_big_map, [k;v] ->
             let%bind k = evaluate_type e k in
             let%bind v = evaluate_type e v in
             ok @@ O.TC_big_map {k;v}
-        | TC_map_or_big_map (k,v) ->
+        | TC_map_or_big_map, [k;v] ->
             let%bind k = evaluate_type e k in
             let%bind v = evaluate_type e v in
             ok @@ O.TC_map_or_big_map {k;v}
-        | TC_contract c ->
+        | TC_contract, [c] ->
             let%bind c = evaluate_type e c in
             ok @@ O.TC_contract c
-        | TC_michelson_pair_right_comb _c | TC_michelson_pair_left_comb _c 
+        | TC_michelson_pair_right_comb, _c | TC_michelson_pair_left_comb, _c 
-        | TC_michelson_or_right_comb _c | TC_michelson_or_left_comb _c ->
+        | TC_michelson_or_right_comb, _c | TC_michelson_or_left_comb, _c ->
           (* not really sure what to do in the new typer, should be converted to a pair using functions defined in Helpers.Typer.Converter *)
           simple_fail "to be implemented"
+        | _ -> fail @@ bad_type_operator t
         in
       return (T_operator (opt))
 

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

@@ -178,28 +178,28 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
       let%bind type_name = match type_name with
       | O.TC_option t -> 
          let%bind t' = untype_type_expression t in
-         ok @@ I.TC_option t'
+         ok @@ (I.TC_option, [t'])
       | O.TC_list   t ->
          let%bind t' = untype_type_expression t in
-         ok @@ I.TC_list t'
+         ok @@ (I.TC_list, [t'])
       | O.TC_set    t ->     
          let%bind t' = untype_type_expression t in
-         ok @@ I.TC_set t'
+         ok @@ (I.TC_set, [t'])
       | O.TC_map   {k;v} ->     
          let%bind k = untype_type_expression k in
          let%bind v = untype_type_expression v in
-         ok @@ I.TC_map (k,v)
+         ok @@ (I.TC_map, [k;v])
       | O.TC_big_map {k;v} ->
          let%bind k = untype_type_expression k in
          let%bind v = untype_type_expression v in
-         ok @@ I.TC_big_map (k,v)
+         ok @@ (I.TC_big_map, [k;v])
       | O.TC_map_or_big_map {k;v} ->     
          let%bind k = untype_type_expression k in
          let%bind v = untype_type_expression v in
-         ok @@ I.TC_map_or_big_map (k,v)
+         ok @@ (I.TC_map_or_big_map, [k;v])
       | O.TC_contract c->
          let%bind c = untype_type_expression c in
-         ok @@ I.TC_contract c
+         ok @@ (I.TC_contract, [c])
       in
       ok @@ I.T_operator (type_name)
     in

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

@@ -97,19 +97,21 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
                         | _        -> failwith "unknown type constructor")
      in
      p_constant csttag []
-  | T_operator (type_name) ->
+  | T_operator (type_name, args) ->
-     let (csttag, args) = T.(match type_name with
+     let csttag = T.(match type_name with
-                                | TC_option o            -> (C_option , [o])
+                                | TC_option                    -> C_option 
-                                | TC_list l              -> (C_list   , [l])
+                                | TC_list                      -> C_list   
-                                | TC_set  s              -> (C_set    , [s])
+                                | TC_set                       -> C_set    
-                                | TC_map  ( k , v )      -> (C_map    , [k;v])
+                                | TC_map                       -> C_map    
-                                | TC_big_map  ( k , v )  -> (C_big_map, [k;v])
+                                | TC_big_map                   -> C_big_map
-                                | TC_map_or_big_map ( k , v) -> (C_map, [k;v])
+                                | TC_map_or_big_map            -> C_map
-                                | TC_contract c          -> (C_contract, [c])
+                                | TC_contract                  -> C_contract
-                                | TC_michelson_pair_right_comb c -> (C_record, [c])
+                                | TC_michelson_pair
-                                | TC_michelson_pair_left_comb c -> (C_record, [c])
+                                | TC_michelson_or
-                                | TC_michelson_or_right_comb c -> (C_record, [c])
+                                | TC_michelson_pair_right_comb -> C_record
-                                | TC_michelson_or_left_comb c -> (C_record, [c])
+                                | TC_michelson_pair_left_comb  -> C_record
+                                | TC_michelson_or_right_comb   -> C_record
+                                | TC_michelson_or_left_comb    -> C_record
                           )
      in
      p_constant csttag (List.map type_expression_to_type_value_copypasted args)

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

@@ -230,6 +230,11 @@ module Errors = struct
     ] in
     error ~data title message ()
 
+  let bad_type_operator type_op =
+    let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in
+    let message () = "" in
+    error title message
+
 end
 open Errors
 
@@ -614,59 +619,60 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
       ok tv
   | T_constant cst ->
       return (T_constant (convert_type_constant cst))
-  | T_operator opt -> ( match opt with
+  | T_operator (op, lst) -> ( match op,lst with
-    | TC_set s -> 
+    | TC_set, [s] -> 
         let%bind s = evaluate_type e s in 
         return @@ T_operator (O.TC_set (s))
-    | TC_option o -> 
+    | TC_option, [o] -> 
         let%bind o = evaluate_type e o in 
         return @@ T_operator (O.TC_option (o))
-    | TC_list l -> 
+    | TC_list, [l] -> 
         let%bind l = evaluate_type e l in 
         return @@ T_operator (O.TC_list (l))
-    | TC_map (k,v) ->
+    | TC_map, [k;v] ->
         let%bind k = evaluate_type e k in 
         let%bind v = evaluate_type e v in 
         return @@ T_operator (O.TC_map {k;v})
-    | TC_big_map (k,v) ->
+    | TC_big_map, [k;v] ->
         let%bind k = evaluate_type e k in 
         let%bind v = evaluate_type e v in 
         return @@ T_operator (O.TC_big_map {k;v})
-    | TC_map_or_big_map (k,v) ->
+    | TC_map_or_big_map, [k;v] ->
         let%bind k = evaluate_type e k in 
         let%bind v = evaluate_type e v in 
         return @@ T_operator (O.TC_map_or_big_map {k;v})
-    | TC_contract c ->
+    | TC_contract, [c] ->
         let%bind c = evaluate_type e c in
         return @@ T_operator (O.TC_contract c)
-    | TC_michelson_pair_right_comb c ->
+    | TC_michelson_pair_right_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_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in
         return @@ record
-    | TC_michelson_pair_left_comb c ->
+    | 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_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in
         return @@ record
-    | TC_michelson_or_right_comb c ->
+    | TC_michelson_or_right_comb, [c] ->
         let%bind c' = evaluate_type e c in
         let%bind cmap = match c'.type_content with
           | T_sum cmap -> ok cmap
           | _ -> fail (michelson_comb_no_variant t.location) in
         let pair = Operators.Typer.Converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in
         return @@ pair
-    | TC_michelson_or_left_comb c ->
+    | TC_michelson_or_left_comb, [c] ->
         let%bind c' = evaluate_type e c in
         let%bind cmap = match c'.type_content with
           | T_sum cmap -> ok cmap
           | _ -> fail (michelson_comb_no_variant t.location) in
         let pair = Operators.Typer.Converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in
         return @@ pair
+    | _ -> fail @@ bad_type_operator t
   )
 
 and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result

src/passes/operators/operators.ml

@@ -32,8 +32,6 @@ module Concrete_to_imperative = struct
     - The left-hand-side is the reserved name in the given front-end.
     - The right-hand-side is the name that will be used in the AST.
   *)
-  let unit_expr = make_t @@ T_constant TC_unit
-
   let type_constants s =
     match s with
       "chain_id"  -> Some TC_chain_id
@@ -53,17 +51,17 @@ module Concrete_to_imperative = struct
 
   let type_operators s =
     match s with
-      "list"         -> Some (TC_list unit_expr)
+      "list"                      -> Some (TC_list)
-    | "option"       -> Some (TC_option unit_expr)
+    | "option"                    -> Some (TC_option)
-    | "set"          -> Some (TC_set unit_expr)
+    | "set"                       -> Some (TC_set)
-    | "map"          -> Some (TC_map (unit_expr,unit_expr))
+    | "map"                       -> Some (TC_map)
-    | "big_map"      -> Some (TC_big_map (unit_expr,unit_expr))
+    | "big_map"                   -> Some (TC_big_map)
-    | "contract"     -> Some (TC_contract unit_expr)
+    | "contract"                  -> Some (TC_contract)
-    | "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb unit_expr)
+    | "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb)
-    | "michelson_pair_left_comb" -> Some (TC_michelson_pair_left_comb unit_expr)
+    | "michelson_pair_left_comb"  -> Some (TC_michelson_pair_left_comb)
-    | "michelson_or_right_comb" -> Some (TC_michelson_or_right_comb unit_expr)
+    | "michelson_or_right_comb"   -> Some (TC_michelson_or_right_comb)
-    | "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb unit_expr)
+    | "michelson_or_left_comb"    -> Some (TC_michelson_or_left_comb)
-    | _              -> None
+    | _                           -> None
 
   let pseudo_modules = function
     | "Tezos.chain_id"           -> Some C_CHAIN_ID

src/stages/1-ast_imperative/PP.ml

@@ -42,30 +42,27 @@ let rec type_expression' :
   | T_variable tv -> type_variable ppf tv
   | T_constant tc -> type_constant ppf tc
   | T_operator to_ -> type_operator f ppf to_
+  | T_annoted (ty, str) -> fprintf ppf "(%a%%%s)" type_expression ty str
 
 and type_expression ppf (te : type_expression) : unit =
   type_expression' type_expression ppf te
 
-and type_operator :
+and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
-        (formatter -> type_expression -> unit)
-    -> formatter
-    -> type_operator
-    -> unit =
   fun f ppf to_ ->
-  let s =
+  let s = match to_ with
-    match to_ with
+    TC_option                    , lst -> Format.asprintf "option(%a)"                     (list_sep_d f) lst
-    | TC_option te -> Format.asprintf "option(%a)" f te
+  | TC_list                      , lst -> Format.asprintf "list(%a)"                       (list_sep_d f) lst
-    | TC_list te -> Format.asprintf "list(%a)" f te
+  | TC_set                       , lst -> Format.asprintf "set(%a)"                        (list_sep_d f) lst
-    | TC_set te -> Format.asprintf "set(%a)" f te
+  | TC_map                       , lst -> Format.asprintf "Map (%a)"                       (list_sep_d f) lst
-    | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
+  | TC_big_map                   , lst -> Format.asprintf "Big Map (%a)"                   (list_sep_d f) lst
-    | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
+  | TC_map_or_big_map            , lst -> Format.asprintf "Map Or Big Map (%a)"            (list_sep_d f) lst
-    | TC_michelson_or (l,_, r,_) -> Format.asprintf "Michelson_or (%a,%a)" f l f r
+  | TC_contract                  , lst -> Format.asprintf "Contract (%a)"                  (list_sep_d f) lst
-    | TC_michelson_pair (l,_, r,_) -> Format.asprintf "Michelson_pair (%a,%a)" f l f r
+  | TC_michelson_pair            , lst -> Format.asprintf "michelson_pair (%a)"            (list_sep_d f) lst                            
-    | TC_michelson_pair_right_comb e -> Format.asprintf "michelson_pair_right_comb (%a)" f e
+  | TC_michelson_or              , lst -> Format.asprintf "michelson_or (%a)"              (list_sep_d f) lst
-    | TC_michelson_pair_left_comb e -> Format.asprintf "michelson_pair_left_comb (%a)" f e
+  | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
-    | TC_michelson_or_right_comb e -> Format.asprintf "michelson_or_right_comb (%a)" f e
+  | TC_michelson_pair_left_comb  , lst -> Format.asprintf "michelson_pair_left_comb (%a)"  (list_sep_d f) lst
-    | TC_michelson_or_left_comb e -> Format.asprintf "michelson_or_left_comb (%a)" f e
+  | TC_michelson_or_right_comb   , lst -> Format.asprintf "michelson_or_right_comb (%a)"   (list_sep_d f) lst
-    | TC_contract te  -> Format.asprintf "Contract (%a)" f te
+  | TC_michelson_or_left_comb    , lst -> Format.asprintf "michelson_or_left_comb (%a)"    (list_sep_d f) lst
   in
   fprintf ppf "(TO_%s)" s
 

src/stages/1-ast_imperative/combinators.ml

@@ -12,10 +12,6 @@ module Errors = struct
       ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
     ] in
     error ~data title message
-  let bad_type_operator type_op =
-    let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
-    let message () = "" in
-    error title message
 end
 open Errors
 
@@ -34,8 +30,8 @@ let t_signature ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_sign
 let t_key ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_key)
 let t_key_hash ?loc ()    : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
 let t_timestamp ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
-let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option o)
+let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
-let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list t)
+let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list, [t])
 let t_variable ?loc n     : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
 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
@@ -56,33 +52,25 @@ let t_sum ?loc m : type_expression =
   let lst = Map.String.to_kv_list m in
   ez_t_sum ?loc lst
 
-let t_function ?loc type1 type2  : type_expression = make_t ?loc @@ T_arrow {type1; type2}
+let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst)
-let t_map ?loc key value         : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
+let t_annoted ?loc ty str : type_expression = make_t ?loc @@ T_annoted (ty, str)
-let t_big_map ?loc key value     : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
-let t_set ?loc key               : type_expression = make_t ?loc @@ T_operator (TC_set key)
-let t_contract ?loc contract     : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
-let t_michelson_or ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_or (l, l_ann, r, r_ann))
-let t_michelson_pair ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair (l, l_ann, r, r_ann))
-let t_michelson_pair_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_right_comb c) 
-let t_michelson_pair_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_left_comb c) 
-let t_michelson_or_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_right_comb c) 
-let t_michelson_or_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_left_comb c) 
 
-(* TODO find a better way than using list*)
+let t_function ?loc type1 type2           : type_expression = make_t ?loc @@ T_arrow {type1; type2}
-let t_operator ?loc op lst: type_expression result =
+let t_map ?loc key value                  : type_expression = make_t ?loc @@ T_operator (TC_map ,[key; value])
-  match op,lst with 
+let t_big_map ?loc key value              : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
-  | TC_set _         , [t] -> ok @@ t_set ?loc t
+let t_set ?loc key                        : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
-  | TC_list _        , [t] -> ok @@ t_list ?loc t
+let t_contract ?loc contract              : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
-  | TC_option _      , [t] -> ok @@ t_option ?loc t
+let t_michelson_or ?loc l l_ann r r_ann   : type_expression = make_t ?loc @@ T_operator (TC_michelson_or, [t_annoted l l_ann; t_annoted r r_ann])
-  | TC_map (_,_)     , [kt;vt] -> ok @@ t_map ?loc kt vt
+let t_michelson_pair ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair, [t_annoted l l_ann; t_annoted r r_ann])
-  | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
+let t_michelson_pair_right_comb ?loc c    : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_right_comb, [c]) 
-  | TC_michelson_or (_,l_ann,_,r_ann) , [l;r] -> ok @@ t_michelson_or ?loc l l_ann r r_ann
+let t_michelson_pair_left_comb ?loc c     : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_left_comb, [c]) 
-  | TC_contract _    , [t] -> ok @@ t_contract t
+let t_michelson_or_right_comb ?loc c      : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_right_comb, [c]) 
-  | TC_michelson_pair_right_comb _ , [c] -> ok @@ t_michelson_pair_right_comb c
+let t_michelson_or_left_comb ?loc c       : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_left_comb, [c]) 
-  | TC_michelson_pair_left_comb _ , [c] -> ok @@ t_michelson_pair_left_comb c
+
-  | TC_michelson_or_right_comb _ , [c] -> ok @@ t_michelson_or_right_comb c
+let get_t_annoted = fun te ->
-  | TC_michelson_or_left_comb _ , [c] -> ok @@ t_michelson_or_left_comb c
+  match te.type_content with
-  | _ , _ -> fail @@ bad_type_operator op
+    T_annoted (te, lst) -> ok (te,lst)
+  | _ -> simple_fail "not a T_annoted"
 
 let make_e ?(loc = Location.generated) expression_content =
   let location = loc in

src/stages/1-ast_imperative/combinators.mli

@@ -46,11 +46,18 @@ val t_michelson_or : ?loc:Location.t -> type_expression -> michelson_prct_annota
   type_expression -> michelson_prct_annotation -> type_expression
 val t_michelson_pair : ?loc:Location.t -> type_expression -> michelson_prct_annotation ->
   type_expression -> michelson_prct_annotation -> type_expression
+val t_michelson_pair_right_comb : ?loc:Location.t -> type_expression -> type_expression
+val t_michelson_pair_left_comb  : ?loc:Location.t -> type_expression -> type_expression
+val t_michelson_or_right_comb   : ?loc:Location.t -> type_expression -> type_expression
+val t_michelson_or_left_comb    : ?loc:Location.t -> type_expression -> type_expression
 
-val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
+val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
 val t_set      : ?loc:Location.t -> type_expression -> type_expression
 val t_contract : ?loc:Location.t -> type_expression -> type_expression
 
+val t_annoted : ?loc:Location.t -> type_expression -> string -> type_expression
+val get_t_annoted : type_expression -> (type_expression* string) result
+
 val make_e : ?loc:Location.t -> expression_content -> expression
 
 val e_literal : ?loc:Location.t -> literal -> expression

src/stages/1-ast_imperative/types.ml

@@ -11,7 +11,8 @@ type type_content =
   | T_arrow of arrow
   | T_variable of type_variable
   | T_constant of type_constant
-  | T_operator of type_operator
+  | T_operator of (type_operator * type_expression list)
+  | T_annoted  of (type_expression * string)
 
 and arrow = {type1: type_expression; type2: type_expression}
 
@@ -21,20 +22,6 @@ and ctor_content = {ctor_type : type_expression ; ctor_decl_pos : int}
 
 and michelson_prct_annotation = string
 
-and type_operator =
-  | TC_contract of type_expression
-  | TC_option of type_expression
-  | TC_list of type_expression
-  | TC_set of type_expression
-  | TC_map of type_expression * type_expression
-  | TC_big_map of type_expression * type_expression
-  | TC_michelson_or of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation
-  | TC_michelson_pair of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation
-  | TC_michelson_or_right_comb of type_expression
-  | TC_michelson_or_left_comb of type_expression
-  | TC_michelson_pair_right_comb of type_expression
-  | TC_michelson_pair_left_comb of type_expression
-
 and type_expression = {type_content: type_content; location: Location.t}
 
 

src/stages/2-ast_sugar/PP.ml

@@ -42,20 +42,22 @@ let rec type_expression' :
 and type_expression ppf (te : type_expression) : unit =
   type_expression' type_expression ppf te
 
-and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit =
+and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
   fun f ppf to_ ->
-  let s =
+  let s = match to_ with
-    match to_ with
+    TC_option                    , lst -> Format.asprintf "option(%a)"                     (list_sep_d f) lst
-    | TC_option te -> Format.asprintf "option(%a)" f te
+  | TC_list                      , lst -> Format.asprintf "list(%a)"                       (list_sep_d f) lst
-    | TC_list te -> Format.asprintf "list(%a)" f te
+  | TC_set                       , lst -> Format.asprintf "set(%a)"                        (list_sep_d f) lst
-    | TC_set te -> Format.asprintf "set(%a)" f te
+  | TC_map                       , lst -> Format.asprintf "Map (%a)"                       (list_sep_d f) lst
-    | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
+  | TC_big_map                   , lst -> Format.asprintf "Big Map (%a)"                   (list_sep_d f) lst
-    | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
+  | TC_map_or_big_map            , lst -> Format.asprintf "Map Or Big Map (%a)"            (list_sep_d f) lst
-    | TC_contract te  -> Format.asprintf "Contract (%a)" f te
+  | TC_contract                  , lst -> Format.asprintf "Contract (%a)"                  (list_sep_d f) lst
-    | TC_michelson_pair_right_comb c -> Format.asprintf "michelson_pair_right_comb (%a)" f c
+  | TC_michelson_pair            , lst -> Format.asprintf "michelson_pair (%a)"            (list_sep_d f) lst                            
-    | TC_michelson_pair_left_comb c -> Format.asprintf "michelson_pair_left_comb (%a)" f c
+  | TC_michelson_or              , lst -> Format.asprintf "michelson_or (%a)"              (list_sep_d f) lst
-    | TC_michelson_or_right_comb c -> Format.asprintf "michelson_or_right_comb (%a)" f c
+  | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
-    | TC_michelson_or_left_comb c -> Format.asprintf "michelson_or_left_comb (%a)" f c
+  | TC_michelson_pair_left_comb  , lst -> Format.asprintf "michelson_pair_left_comb (%a)"  (list_sep_d f) lst
+  | TC_michelson_or_right_comb   , lst -> Format.asprintf "michelson_or_right_comb (%a)"   (list_sep_d f) lst
+  | TC_michelson_or_left_comb    , lst -> Format.asprintf "michelson_or_left_comb (%a)"    (list_sep_d f) lst
   in
   fprintf ppf "(TO_%s)" s
 

src/stages/2-ast_sugar/combinators.ml

@@ -12,10 +12,6 @@ module Errors = struct
       ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
     ] in
     error ~data title message
-  let bad_type_operator type_op =
-    let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
-    let message () = "" in
-    error title message
 end
 open Errors
 
@@ -40,8 +36,8 @@ let t_signature ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_sign
 let t_key ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_key)
 let t_key_hash ?loc ()    : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
 let t_timestamp ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
-let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option o)
+let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
-let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list t)
+let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list, [t])
 let t_variable ?loc n     : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
 let t_record_ez ?loc lst =
   let lst = List.map (fun (k, v) -> (Label k, v)) lst in
@@ -65,21 +61,12 @@ let t_sum ?loc m : type_expression =
   ez_t_sum ?loc lst
 
 let t_function ?loc type1 type2  : type_expression = make_t ?loc @@ T_arrow {type1; type2}
-let t_map ?loc key value         : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
+let t_map ?loc key value                  : type_expression = make_t ?loc @@ T_operator (TC_map ,[key; value])
-let t_big_map ?loc key value     : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
+let t_big_map ?loc key value              : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
-let t_set ?loc key               : type_expression = make_t ?loc @@ T_operator (TC_set key)
+let t_set ?loc key                        : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
-let t_contract ?loc contract     : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
+let t_contract ?loc contract              : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
 
-(* TODO find a better way than using list*)
+let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst)
-let t_operator ?loc op lst: type_expression result =
-  match op,lst with 
-  | TC_set _         , [t] -> ok @@ t_set ?loc t
-  | TC_list _        , [t] -> ok @@ t_list ?loc t
-  | TC_option _      , [t] -> ok @@ t_option ?loc t
-  | TC_map (_,_)     , [kt;vt] -> ok @@ t_map ?loc kt vt
-  | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
-  | TC_contract _    , [t] -> ok @@ t_contract ?loc t
-  | _ , _ -> fail @@ bad_type_operator op
 
 let make_e ?(loc = Location.generated) expression_content =
   let location = loc in

src/stages/2-ast_sugar/combinators.mli

@@ -41,9 +41,11 @@ val t_sum    : ?loc:Location.t -> ctor_content Map.String.t -> type_expression
 val ez_t_sum : ?loc:Location.t -> ( string * ctor_content ) list -> type_expression
 
 val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
-val t_map      : ?loc:Location.t -> type_expression -> type_expression -> type_expression
 
-val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
+val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
+val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_contract : ?loc:Location.t -> type_expression -> type_expression
 val t_set      : ?loc:Location.t -> type_expression -> type_expression
 
 val make_e : ?loc:Location.t -> expression_content -> expression

src/stages/2-ast_sugar/types.ml

@@ -15,7 +15,7 @@ type type_content =
   | T_arrow of arrow
   | T_variable of type_variable
   | T_constant of type_constant
-  | T_operator of type_operator
+  | T_operator of (type_operator * type_expression list)
 
 and arrow = {type1: type_expression; type2: type_expression}
 
@@ -23,18 +23,6 @@ and ctor_content = {ctor_type : type_expression ; michelson_annotation : string
 
 and field_content = {field_type : type_expression ; michelson_annotation : string option ; field_decl_pos : int}
 
-and type_operator =
-  | TC_contract of type_expression
-  | TC_option of type_expression
-  | TC_list of type_expression
-  | TC_set of type_expression
-  | TC_map of type_expression * type_expression
-  | TC_big_map of type_expression * type_expression
-  | TC_michelson_pair_right_comb of type_expression
-  | TC_michelson_pair_left_comb of type_expression
-  | TC_michelson_or_right_comb of type_expression
-  | TC_michelson_or_left_comb of type_expression
-
 and type_expression = {type_content: type_content; location: Location.t}
 
 

src/stages/3-ast_core/combinators.ml

@@ -12,10 +12,6 @@ module Errors = struct
       ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
     ] in
     error ~data title message
-  let bad_type_operator type_op =
-    let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
-    let message () = "" in
-    error title message
 end
 open Errors
 
@@ -40,8 +36,8 @@ let t_signature ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_sign
 let t_key ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_key)
 let t_key_hash ?loc ()    : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
 let t_timestamp ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
-let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option o)
+let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
-let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list t)
+let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list, [t])
 let t_variable ?loc n     : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
 let t_record_ez ?loc lst =
   let lst = List.map (fun (k, v) -> (Label k, v)) lst in
@@ -63,21 +59,12 @@ let t_sum ?loc m : type_expression =
   ez_t_sum ?loc lst
 
 let t_function ?loc type1 type2  : type_expression = make_t ?loc @@ T_arrow {type1; type2}
-let t_map ?loc key value         : type_expression = make_t ?loc @@ T_operator (TC_map (key, value))
-let t_big_map ?loc key value     : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value))
-let t_set ?loc key               : type_expression = make_t ?loc @@ T_operator (TC_set key)
-let t_contract ?loc contract     : type_expression = make_t ?loc @@ T_operator (TC_contract contract)
 
-(* TODO find a better way than using list*)
+let t_operator ?loc op lst       : type_expression = make_t ?loc @@ T_operator (op, lst)
-let t_operator ?loc op lst: type_expression result =
+let t_map ?loc key value         : type_expression = make_t ?loc @@ T_operator (TC_map, [key; value])
-  match op,lst with 
+let t_big_map ?loc key value     : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
-  | TC_set _         , [t] -> ok @@ t_set ?loc t
+let t_set ?loc key               : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
-  | TC_list _        , [t] -> ok @@ t_list ?loc t
+let t_contract ?loc contract     : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
-  | TC_option _      , [t] -> ok @@ t_option ?loc t
-  | TC_map (_,_)     , [kt;vt] -> ok @@ t_map kt ?loc vt
-  | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt
-  | TC_contract _    , [t] -> ok @@ t_contract ?loc t
-  | _ , _ -> fail @@ bad_type_operator op
 
 let make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc }
 

src/stages/3-ast_core/combinators.mli

@@ -41,9 +41,11 @@ val t_sum    : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expres
 val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression
 
 val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
-val t_map      : ?loc:Location.t -> type_expression -> type_expression -> type_expression
 
-val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result
+val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
+val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_contract : ?loc:Location.t -> type_expression -> type_expression
 val t_set      : ?loc:Location.t -> type_expression -> type_expression
 
 val make_e : ?loc:Location.t -> expression_content -> expression

src/stages/common/PP.ml

@@ -239,25 +239,22 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
   and type_expression ppf (te : type_expression) : unit =
     type_expression' type_expression ppf te
 
-  and type_operator :
+  and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
-         (formatter -> type_expression -> unit)
-      -> formatter
-      -> type_operator
-      -> unit =
    fun f ppf to_ ->
-    let s =
+    let s = match to_ with
-      match to_ with
+      TC_option                    , lst -> Format.asprintf "option(%a)"                     (list_sep_d f) lst
-      | TC_option te -> Format.asprintf "option(%a)" f te
+    | TC_list                      , lst -> Format.asprintf "list(%a)"                       (list_sep_d f) lst
-      | TC_list te -> Format.asprintf "list(%a)" f te
+    | TC_set                       , lst -> Format.asprintf "set(%a)"                        (list_sep_d f) lst
-      | TC_set te -> Format.asprintf "set(%a)" f te
+    | TC_map                       , lst -> Format.asprintf "Map (%a)"                       (list_sep_d f) lst
-      | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
+    | TC_big_map                   , lst -> Format.asprintf "Big Map (%a)"                   (list_sep_d f) lst
-      | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
+    | TC_map_or_big_map            , lst -> Format.asprintf "Map Or Big Map (%a)"            (list_sep_d f) lst
-      | TC_map_or_big_map (k, v) -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v
+    | TC_contract                  , lst -> Format.asprintf "Contract (%a)"                  (list_sep_d f) lst
-      | TC_contract te  -> Format.asprintf "Contract (%a)" f te
+    | TC_michelson_pair            , lst -> Format.asprintf "michelson_pair (%a)"            (list_sep_d f) lst                            
-      | TC_michelson_pair_right_comb c -> Format.asprintf "michelson_pair_right_comb (%a)" f c
+    | TC_michelson_or              , lst -> Format.asprintf "michelson_or (%a)"              (list_sep_d f) lst
-      | TC_michelson_pair_left_comb c -> Format.asprintf "michelson_pair_left_comb (%a)" f c
+    | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
-      | TC_michelson_or_right_comb c -> Format.asprintf "michelson_or_right_comb (%a)" f c
+    | TC_michelson_pair_left_comb  , lst -> Format.asprintf "michelson_pair_left_comb (%a)"  (list_sep_d f) lst
-      | TC_michelson_or_left_comb c -> Format.asprintf "michelson_or_left_comb (%a)" f c
+    | TC_michelson_or_right_comb   , lst -> Format.asprintf "michelson_or_right_comb (%a)"   (list_sep_d f) lst
+    | TC_michelson_or_left_comb    , lst -> Format.asprintf "michelson_or_left_comb (%a)"    (list_sep_d f) lst
     in
     fprintf ppf "(type_operator: %s)" s
 end

src/stages/common/types.ml

@@ -29,6 +29,21 @@ type 'a constructor_map = 'a CMap.t
     | TC_signature
     | TC_timestamp
     | TC_void
+  and type_operator =
+    | TC_contract
+    | TC_option
+    | TC_list
+    | TC_set
+    | TC_map
+    | TC_big_map
+    | TC_map_or_big_map
+    | TC_michelson_pair
+    | TC_michelson_or
+    | TC_michelson_pair_right_comb
+    | TC_michelson_pair_left_comb
+    | TC_michelson_or_right_comb
+    | TC_michelson_or_left_comb
+
 module type AST_PARAMETER_TYPE = sig
   type type_meta
 end
@@ -44,7 +59,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
     | T_arrow of arrow
     | T_variable of type_variable
     | T_constant of type_constant
-    | T_operator of type_operator
+    | T_operator of (type_operator * type_expression list)
 
   and arrow = {type1: type_expression; type2: type_expression}
   
@@ -52,69 +67,32 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
 
   and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int}
 
-  and type_operator =
-    | TC_contract of type_expression
-    | TC_option of type_expression
-    | TC_list of type_expression
-    | TC_set of type_expression
-    | TC_map of type_expression * type_expression
-    | TC_big_map of type_expression * type_expression
-    | TC_map_or_big_map of type_expression * type_expression
-    | TC_michelson_pair_right_comb of type_expression
-    | TC_michelson_pair_left_comb of type_expression
-    | TC_michelson_or_right_comb of type_expression
-    | TC_michelson_or_left_comb of type_expression
-
 
   and type_expression = {type_content: type_content; location: Location.t; type_meta: type_meta}
 
   open Trace
-  let map_type_operator f = function
-      TC_contract x -> TC_contract (f x)
-    | TC_option x -> TC_option (f x)
-    | TC_list x -> TC_list (f x)
-    | TC_set x -> TC_set (f x)
-    | TC_map (x , y) -> TC_map (f x , f y)
-    | TC_big_map (x , y)-> TC_big_map (f x , f y)
-    | TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y)
-    | TC_michelson_pair_right_comb c -> TC_michelson_pair_right_comb (f c)
-    | TC_michelson_pair_left_comb c -> TC_michelson_pair_left_comb (f c)
-    | TC_michelson_or_right_comb c -> TC_michelson_or_right_comb (f c)
-    | TC_michelson_or_left_comb c -> TC_michelson_or_left_comb (f c)
-
-  let bind_map_type_operator f = function
-      TC_contract x -> let%bind x = f x in ok @@ TC_contract x
-    | TC_option x -> let%bind x = f x in ok @@ TC_option x
-    | TC_list x -> let%bind x = f x in ok @@ TC_list x
-    | TC_set x -> let%bind x = f x in ok @@ TC_set x
-    | TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
-    | TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
-    | TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y)
-    | TC_michelson_pair_right_comb c -> let%bind c = f c in ok @@ TC_michelson_pair_right_comb c
-    | TC_michelson_pair_left_comb c -> let%bind c = f c in ok @@ TC_michelson_pair_left_comb c
-    | TC_michelson_or_right_comb c -> let%bind c = f c in ok @@ TC_michelson_or_right_comb c
-    | TC_michelson_or_left_comb c -> let%bind c = f c in ok @@ TC_michelson_or_left_comb c
-
   let type_operator_name = function
-        TC_contract _ -> "TC_contract"
+        TC_contract                  -> "TC_contract"
-      | TC_option   _ -> "TC_option"
+      | TC_option                    -> "TC_option"
-      | TC_list     _ -> "TC_list"
+      | TC_list                      -> "TC_list"
-      | TC_set      _ -> "TC_set"
+      | TC_set                       -> "TC_set"
-      | TC_map      _ -> "TC_map"
+      | TC_map                       -> "TC_map"
-      | TC_big_map  _ -> "TC_big_map"
+      | TC_big_map                   -> "TC_big_map"
-      | TC_map_or_big_map _ -> "TC_map_or_big_map"
+      | TC_map_or_big_map            -> "TC_map_or_big_map"
-      | TC_michelson_pair_right_comb _ -> "TC_michelson_pair_right_comb" 
+      | TC_michelson_pair            -> "TC_michelson_pair"
-      | TC_michelson_pair_left_comb _ -> "TC_michelson_pair_left_comb" 
+      | TC_michelson_or              -> "TC_michelson_or"
-      | TC_michelson_or_right_comb _ -> "TC_michelson_or_right_comb" 
+      | TC_michelson_pair_right_comb -> "TC_michelson_pair_right_comb" 
-      | TC_michelson_or_left_comb _ -> "TC_michelson_or_left_comb" 
+      | TC_michelson_pair_left_comb  -> "TC_michelson_pair_left_comb" 
+      | TC_michelson_or_right_comb   -> "TC_michelson_or_right_comb" 
+      | TC_michelson_or_left_comb    -> "TC_michelson_or_left_comb" 
 
   let type_expression'_of_string = function
-    | "TC_contract" , [x]     -> ok @@ T_operator(TC_contract x)
+    | "TC_contract" , [x]     -> ok @@ T_operator(TC_contract, [x])
-    | "TC_option"   , [x]     -> ok @@ T_operator(TC_option x)
+    | "TC_option"   , [x]     -> ok @@ T_operator(TC_option, [x])
-    | "TC_list"     , [x]     -> ok @@ T_operator(TC_list x)
+    | "TC_list"     , [x]     -> ok @@ T_operator(TC_list, [x])
-    | "TC_set"      , [x]     -> ok @@ T_operator(TC_set x)
+    | "TC_set"      , [x]     -> ok @@ T_operator(TC_set, [x])
-    | "TC_map"      , [x ; y] -> ok @@ T_operator(TC_map (x , y))
+    | "TC_map"      , [x ; y] -> ok @@ T_operator(TC_map, [x ; y])
-    | "TC_big_map"  , [x ; y] -> ok @@ T_operator(TC_big_map (x, y))
+    | "TC_big_map"  , [x ; y] -> ok @@ T_operator(TC_big_map, [x; y])
     | ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
       failwith "internal error: wrong number of arguments for type operator"
 
@@ -137,17 +115,19 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
       failwith "internal error: unknown type operator"
 
   let string_of_type_operator = function
-    | TC_contract       x       -> "TC_contract"     , [x]
+    | TC_contract                  , lst -> "TC_contract"                  , lst
-    | TC_option         x       -> "TC_option"       , [x]
+    | TC_option                    , lst -> "TC_option"                    , lst
-    | TC_list           x       -> "TC_list"         , [x]
+    | TC_list                      , lst -> "TC_list"                      , lst
-    | TC_set            x       -> "TC_set"          , [x]
+    | TC_set                       , lst -> "TC_set"                       , lst
-    | TC_map            (x , y) -> "TC_map"          , [x ; y]
+    | TC_map                       , lst -> "TC_map"                       , lst
-    | TC_big_map        (x , y) -> "TC_big_map"      , [x ; y]
+    | TC_big_map                   , lst -> "TC_big_map"                   , lst
-    | TC_map_or_big_map (x , y) -> "TC_map_or_big_map"  , [x ; y]
+    | TC_map_or_big_map            , lst -> "TC_map_or_big_map"            , lst
-    | TC_michelson_pair_right_comb c -> "TC_michelson_pair_right_comb" , [c]
+    | TC_michelson_pair            , lst -> "TC_michelson_pair"            , lst
-    | TC_michelson_pair_left_comb c -> "TC_michelson_pair_left_comb" , [c]
+    | TC_michelson_or              , lst -> "TC_michelson_or"              , lst
-    | TC_michelson_or_right_comb c -> "TC_michelson_or_right_comb" , [c]
+    | TC_michelson_pair_right_comb , lst -> "TC_michelson_pair_right_comb" , lst
-    | TC_michelson_or_left_comb c -> "TC_michelson_or_left_comb" , [c]
+    | TC_michelson_pair_left_comb  , lst -> "TC_michelson_pair_left_comb"  , lst
+    | TC_michelson_or_right_comb   , lst -> "TC_michelson_or_right_comb"   , lst
+    | TC_michelson_or_left_comb    , lst -> "TC_michelson_or_left_comb"    , lst
 
   let string_of_type_constant = function
     | TC_unit      -> "TC_unit", []

src/stages/typesystem/misc.ml

@@ -91,13 +91,12 @@ module Substitution = struct
       | Ast_core.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record"
       | Ast_core.T_arrow _ -> failwith "TODO: subst: unimplemented case s_type_expression arrow"
       | Ast_core.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression variable"
-      | Ast_core.T_operator op ->
+      | Ast_core.T_operator (op,lst) ->
-         let%bind op =
+         let%bind lst = bind_map_list
-           Ast_core.bind_map_type_operator
              (s_abstr_type_expression ~substs)
-             op in
+             lst in
          (* TODO: when we have generalized operators, we might need to subst the operator name itself? *)
-         ok @@ Ast_core.T_operator op
+         ok @@ Ast_core.T_operator (op, lst)
       | Ast_core.T_constant constant ->
          ok @@ Ast_core.T_constant constant