Merge branch 'fix/print-record-in-lexicographic-order' into 'dev'

Print record in lexicographic order

See merge request ligolang/ligo!393

gitlab-pages/docs/intro/installation.md

@@ -20,7 +20,7 @@ If this is your first time using Docker, you probably want to set up a global LI
 
 ### Setting up a globally available `ligo` executable
 
-> You can install additional ligo versions by replacing `next` with the required version number
+> You can install additional ligo versions by replacing `next` with the desired version number
 
 Download the latest binaries here: https://gitlab.com/ligolang/ligo/pipelines/85536879/builds or get the latest pre-release:
 

scripts/test_cli.sh

@@ -7,7 +7,7 @@ dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo m
 
 expected_compiled_parameter="(Right 1)";
 expected_compiled_storage=1;
-expected_dry_run_output="( [] , 2 )";
+expected_dry_run_output="( list[] , 2 )";
 
 if [ "$compiled_storage" != "$expected_compiled_storage" ]; then
     echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead";

src/bin/cli.ml

@@ -259,7 +259,7 @@ let interpret =
         let%bind failstring = Run.failwith_to_string fail_res in
         ok @@ Format.asprintf "%s" failstring
       | Success value' ->
-        let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value' in
+        let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_expression value' in
         ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
   in
   let term =
@@ -342,6 +342,7 @@ let run_function =
     let      env             = Ast_typed.program_environment typed_prg in
     let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
 
+
     let%bind simplified_param = Compile.Of_source.compile_expression v_syntax parameter in
     let%bind app              = Compile.Of_simplified.apply entry_point simplified_param in
     let%bind (typed_app,_)    = Compile.Of_simplified.compile_expression ~env ~state app in

src/bin/expect_tests/failwith_tests.ml

@@ -21,7 +21,7 @@ let%expect_test _ =
 
   run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=pascaligo" ] ;
   [%expect {|
-    Unit |}];
+    unit |}];
 
   run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=pascaligo" ] ;
   [%expect {|
@@ -29,7 +29,7 @@ let%expect_test _ =
 
   run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=cameligo" ] ;
   [%expect {|
-    Unit |}];
+    unit |}];
 
   run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=cameligo" ] ;
   [%expect {|

src/bin/expect_tests/literals.ml

@@ -2,12 +2,12 @@ open Cli_expect
 
 let%expect_test _ =
   run_ligo_good ["interpret" ; "(\"edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7\":signature)" ; "--syntax=pascaligo"] ;
-  [%expect {| signature edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7 |}]
+  [%expect {| Signature edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7 |}]
 
 let%expect_test _ =
   run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
   [%expect {|
-    ligo: in file "", line 0, characters 1-32. Badly formatted literal: signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
+    ligo: in file "", line 0, characters 1-32. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
 
 
      If you're not sure how to fix this error, you can

src/bin/expect_tests/misc_cli_commands.ml

@@ -4,7 +4,7 @@ open Cli_expect
 let%expect_test _ =
   run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "a" ] ;
   [%expect {|
-    {foo = +0 , bar = "bar"} |} ];
+    record[bar -> "bar" , foo -> +0] |} ];
 
   run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "b" ] ;
   [%expect {|

src/bin/expect_tests/typer_error_tests.ml

@@ -41,7 +41,7 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_3.mligo", line 3, characters 34-53. different number of arguments to type constructors: Expected these two n-ary type constructors to be the same, but they have different numbers of arguments (both use the TC_tuple type constructor, but they have 3 and 2 arguments, respectively) {"a":"(TO_tuple[int , string , bool])","b":"(TO_tuple[int , string])","op":"TC_tuple","len_a":"3","len_b":"2"}
+    ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"( int * string * bool )","b":"( int * string )"}
 
 
      If you're not sure how to fix this error, you can
@@ -54,7 +54,7 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in record:  {"key_a":"d","key_b":"c"}
+    ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in records:  {"key_a":"c","key_b":"b","a":"record[a -> int , c -> bool , d -> string]","b":"record[a -> int , b -> string , c -> bool]"}
 
 
      If you're not sure how to fix this error, you can
@@ -93,7 +93,7 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "error_typer_7.mligo", line 4, characters 18-48. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[b -> string , a -> int]","b":"record[c -> bool , b -> string , a -> int]"}
+    ligo: in file "error_typer_7.mligo", line 4, characters 18-48. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[a -> int , b -> string]","b":"record[a -> int , b -> string , c -> bool]"}
 
 
      If you're not sure how to fix this error, you can
@@ -106,7 +106,7 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
   [%expect {|
-    ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[profile -> bytes , owner -> address , controller -> address]
+    ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , owner -> address , profile -> bytes]
 
      If you're not sure how to fix this error, you can
      do one of the following:

src/main/compile/of_simplified.ml

@@ -6,17 +6,17 @@ let compile (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solv
   ok @@ (prog_typed, state)
 
 let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression)
-    : (Ast_typed.value * Typer.Solver.state) result =
+    : (Ast_typed.expression * Typer.Solver.state) result =
   let () = Typer.Solver.discard_state state in
   Typer.type_expression_subst env state ae
 
 let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result =
   let name = Var.of_name entry_point in
   let entry_point_var : Ast_simplified.expression =
-    { expression = Ast_simplified.E_variable name ;
+    { expression_content = Ast_simplified.E_variable name ;
       location = Virtual "generated entry-point variable" } in
   let applied : Ast_simplified.expression = 
-    { expression = Ast_simplified.E_application (entry_point_var, param) ;
+    { expression_content = Ast_simplified.E_application {expr1=entry_point_var; expr2=param} ;
       location = Virtual "generated application" } in
   ok applied
 

src/main/compile/of_typed.ml

@@ -4,20 +4,22 @@ open Ast_typed
 let compile : Ast_typed.program -> Mini_c.program result = fun p ->
   Transpiler.transpile_program p
 
-let compile_expression : annotated_expression -> Mini_c.expression result = fun e ->
+let compile_expression : expression -> Mini_c.expression result = fun e ->
   Transpiler.transpile_annotated_expression e
 
 type check_type = Check_parameter | Check_storage
-let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.value -> unit result =
+let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.expression -> unit result =
     fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") (
   let%bind entry_point = Ast_typed.get_entry contract entry in
-  match entry_point.type_annotation.type_value' with
-  | T_arrow (args,_) -> (
-      match args.type_value' with
-      | T_operator (TC_tuple [param_exp;storage_exp]) -> (
+  match entry_point.type_expression.type_content with
+  | T_arrow {type1=args} -> (
+      match args.type_content with
+      | T_record m when LMap.cardinal m = 2 -> (
+        let param_exp = LMap.find (Label "0") m in
+        let storage_exp = LMap.find (Label "1") m in
           match c with
-          | Check_parameter -> assert_type_value_eq (param_exp,   param.type_annotation)
-          | Check_storage   -> assert_type_value_eq (storage_exp, param.type_annotation)
+          | Check_parameter -> assert_type_expression_eq (param_exp,   param.type_expression)
+          | Check_storage   -> assert_type_expression_eq (storage_exp, param.type_expression)
       )
       | _ -> dummy_fail
   )

src/main/compile/wrapper.ml

@@ -0,0 +1,12 @@
+open Trace
+
+let source_to_typed syntax source_file =
+  let%bind simplified  = Of_source.compile source_file syntax in
+  let%bind typed,state = Of_simplified.compile simplified in
+  let env = Ast_typed.program_environment typed in
+  ok (typed,state,env)
+
+let source_to_typed_expression ~env ~state parameter syntax =
+  let%bind simplified = Of_source.compile_expression syntax parameter in
+  let%bind (typed,_) = Of_simplified.compile_expression ~env ~state simplified in
+  ok typed

src/main/uncompile/uncompile.ml

@@ -4,9 +4,9 @@ type ret_type = Function | Expression
 let uncompile_value func_or_expr program entry ex_ty_value =
   let%bind entry_expression = Ast_typed.get_entry program entry in
   let%bind output_type = match func_or_expr with
-    | Expression -> ok entry_expression.type_annotation
+    | Expression -> ok entry_expression.type_expression
     | Function ->
-      let%bind (_,output_type) =  Ast_typed.get_t_function entry_expression.type_annotation in
+      let%bind (_,output_type) =  Ast_typed.get_t_function entry_expression.type_expression in
       ok output_type in
   let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
   let%bind typed = Transpiler.untranspile mini_c output_type in

src/passes/1-parser/pascaligo/AST.ml

@@ -789,3 +789,6 @@ let rhs_to_region = expr_to_region
 let selection_to_region = function
   FieldName {region; _}
 | Component {region; _} -> region
+
+let map_ne_injection f ne_injection =
+  { ne_injection with ne_elements = nsepseq_map f ne_injection.ne_elements }

src/passes/2-simplify/cameligo.ml

@@ -194,13 +194,13 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
       | Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
     )
   | TFun x -> (
-      let%bind (a , b) =
+      let%bind (type1 , type2) =
         let (a , _ , b) = x.value in
         let%bind a = simpl_type_expression a in
         let%bind b = simpl_type_expression b in
         ok (a , b)
       in
-      ok @@ make_t @@ T_arrow (a , b)
+      ok @@ make_t @@ T_arrow {type1;type2}
     )
   | TApp x -> (
       let (name, tuple) = x.value in
@@ -247,7 +247,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
   | [hd] -> simpl_type_expression hd
   | lst ->
       let%bind lst = bind_map_list simpl_type_expression lst in
-      ok @@ make_t @@ T_operator (TC_tuple lst)
+      ok @@ t_tuple lst
 
 let rec simpl_expression :
   Raw.expr -> expr result = fun t ->
@@ -261,13 +261,13 @@ let rec simpl_expression :
     let path' =
       let aux (s:Raw.selection) =
         match s with
-          FieldName property -> Access_record property.value
-        | Component index -> Access_tuple (Z.to_int (snd index.value))
+          FieldName property -> property.value
+        | Component index -> Z.to_string (snd index.value)
       in
       List.map aux @@ npseq_to_list path in
-    return @@ e_accessor ~loc var path'
+    return @@ List.fold_left (e_accessor ~loc ) var path'
   in
-  let simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
+  let simpl_path : Raw.path -> string * label list = fun p ->
     match p with
     | Raw.Name v -> (v.value , [])
     | Raw.Path p -> (
@@ -277,8 +277,8 @@ let rec simpl_expression :
         let path' =
           let aux (s:Raw.selection) =
             match s with
-            | FieldName property -> Access_record property.value
-            | Component index -> Access_tuple (Z.to_int (snd index.value))
+            | FieldName property -> Label property.value
+            | Component index -> Label (Z.to_string (snd index.value))
           in
           List.map aux @@ npseq_to_list path in
         (var , path')
@@ -289,7 +289,9 @@ let rec simpl_expression :
     let (name, path) = simpl_path u.record in
     let record = match path with
     | [] -> e_variable (Var.of_name name)
-    | _ -> e_accessor (e_variable (Var.of_name name)) path in
+    | _ ->
+      let aux expr (Label l) = e_accessor expr l in
+      List.fold_left aux (e_variable (Var.of_name name)) path in 
     let updates = u.updates.value.ne_elements in
     let%bind updates' =
       let aux (f:Raw.field_path_assign Raw.reg) =
@@ -304,7 +306,7 @@ let rec simpl_expression :
         | [] -> failwith "error in parsing"
         | hd :: [] -> ok @@ e_update ~loc record hd expr
         | hd :: tl -> 
-          let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in
+          let%bind expr = (aux (e_accessor ~loc record hd) tl) in
           ok @@ e_update ~loc record hd expr 
       in
       aux ur path in
@@ -352,19 +354,20 @@ let rec simpl_expression :
         match variables with
         | hd :: [] ->
           if (List.length prep_vars = 1)
-          then e_let_in hd inline rhs_b_expr body
-          else e_let_in hd inline (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body
+          then e_let_in hd false inline rhs_b_expr body
+          else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
         | hd :: tl ->
           e_let_in hd
+          false
           inline
-          (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)])
+          (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1)))
           (chain_let_in tl body)
         | [] -> body (* Precluded by corner case assertion above *)
       in
       if List.length prep_vars = 1
       then ok (chain_let_in prep_vars body)
       (* Bind the right hand side so we only evaluate it once *)
-      else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body))
+      else ok (e_let_in (rhs_b, ty_opt) false inline rhs' (chain_let_in prep_vars body))
 
       (* let f p1 ps... = rhs in body *)
       | (f, p1 :: ps) ->
@@ -413,8 +416,7 @@ let rec simpl_expression :
         @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
         @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
         @@ npseq_to_list r.ne_elements in
-      let map = SMap.of_list fields in
-      return @@ e_record ~loc map
+      return @@ e_record_ez ~loc fields
   | EProj p -> simpl_projection p
   | EUpdate u -> simpl_update u
   | EConstr (ESomeApp a) ->
@@ -501,7 +503,7 @@ let rec simpl_expression :
                   | Raw.PVar y ->
                     let var_name = Var.of_name y.value in
                     let%bind type_expr = simpl_type_expression x'.type_expr in
-                    return @@ e_let_in (var_name , Some type_expr) false e rhs
+                    return @@ e_let_in (var_name , Some type_expr) false false e rhs
                   | _ -> default_action ()
                 )
               | _ -> default_action ()
@@ -810,7 +812,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
           ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , inline, rhs'))]
     )
 
-and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =
+and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result =
   fun t ->
   let open Raw in
   let rec get_var (t:Raw.pattern) =
@@ -931,5 +933,5 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =
       in bind_or (as_option () , as_variant ())
 
 let simpl_program : Raw.ast -> program result = fun t ->
-  let%bind decls = bind_list (List.map simpl_declaration @@ nseq_to_list t.decl) in
+  let%bind decls = bind_map_list simpl_declaration @@ nseq_to_list t.decl in
   ok @@ List.concat @@ decls

src/passes/2-simplify/pascaligo.ml

@@ -16,17 +16,17 @@ let pseq_to_list = function
 let get_value : 'a Raw.reg -> 'a = fun x -> x.value
 let is_compiler_generated name = String.contains (Var.to_name name) '#'
 
-let detect_local_declarations (for_body : expression) =
+let _detect_local_declarations (for_body : expression) =
   let%bind aux = Self_ast_simplified.fold_expression
     (fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) ->
       if cur_loop then 
-        match ass_exp.expression with
-        | E_let_in {binder;rhs = _;result = _} ->
-          let (name,_) = binder in
+        match ass_exp.expression_content with
+        | E_let_in {let_binder;mut=false;rhs = _;let_result = _} ->
+          let (name,_) = let_binder in
           ok (name::nlist, cur_loop)
-        | E_constant (C_MAP_FOLD, _)
-        | E_constant (C_SET_FOLD, _)
-        | E_constant (C_LIST_FOLD, _) -> ok @@ (nlist, false)
+        | E_constant {cons_name=C_MAP_FOLD;arguments= _}
+        | E_constant {cons_name=C_SET_FOLD;arguments= _}
+        | E_constant {cons_name=C_LIST_FOLD;arguments= _} -> ok @@ (nlist, false)
         | _ -> ok (nlist, cur_loop)
       else
         ok @@ (nlist, cur_loop)
@@ -35,17 +35,14 @@ let detect_local_declarations (for_body : expression) =
     for_body in
   ok @@ fst aux
 
-let detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
+let _detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
   let%bind captured_names = Self_ast_simplified.fold_expression
     (fun (prev : expression_variable list) (ass_exp : expression) ->
-      match ass_exp.expression with
-      | E_assign ( name , _ , _ ) ->
-        if is_compiler_generated name then ok prev
-        else ok (name::prev)
-      | E_constant (n, [a;b])
+      match ass_exp.expression_content with
+      | E_constant {cons_name=n;arguments=[a;b]}
         when n=C_OR || n=C_AND || n=C_LT || n=C_GT ||
              n=C_LE || n=C_GE  || n=C_EQ || n=C_NEQ -> (
-          match (a.expression,b.expression) with
+          match (a.expression_content,b.expression_content) with
           | E_variable na , E_variable nb -> 
             let ret = [] in
             let ret = if not (is_compiler_generated na) then
@@ -66,6 +63,92 @@ let detect_free_variables (for_body : expression) (local_decl_names : expression
   ok @@ SSet.elements
      @@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names)
 
+and repair_mutable_variable (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
+  let%bind captured_names = Self_ast_simplified.fold_map_expression
+    (* TODO : these should use Variables sets *)
+    (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
+      match ass_exp.expression_content with
+        | E_let_in {let_binder;mut=false;rhs;let_result} ->
+          let (name,_) = let_binder in
+          ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result)
+        | E_let_in {let_binder;mut=true; rhs;let_result} ->
+          let (name,_) = let_binder in
+          if List.mem name decl_var then 
+            ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result)
+          else(
+            let free_var = if (List.mem name free_var) then free_var else name::free_var in
+            let expr = e_let_in (env,None) false false (e_update (e_variable env) (Var.show name) (e_variable name)) let_result in
+            ok (true,(decl_var, free_var), e_let_in let_binder false  false rhs expr)
+          )
+        | E_variable name ->
+          if List.mem name decl_var || List.mem name free_var || Var.equal name env then 
+            ok (true,(decl_var, free_var), e_variable name)
+          else
+            ok (true, (decl_var, name::free_var), e_variable name)
+        | E_constant {cons_name=C_MAP_FOLD;arguments= _}
+        | E_constant {cons_name=C_SET_FOLD;arguments= _}
+        | E_constant {cons_name=C_LIST_FOLD;arguments= _} 
+        | E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp)
+      | _ -> ok (true, (decl_var, free_var),ass_exp)
+    )
+      (element_names,[])
+      for_body in
+  ok @@ captured_names
+
+and repair_mutable_variable_for_collect (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
+  let%bind captured_names = Self_ast_simplified.fold_map_expression
+    (* TODO : these should use Variables sets *)
+    (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
+      match ass_exp.expression_content with
+        | E_let_in {let_binder;mut=false;rhs;let_result} ->
+          let (name,_) = let_binder in
+          ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result)
+        | E_let_in {let_binder;mut=true; rhs;let_result} ->
+          let (name,_) = let_binder in
+          if List.mem name decl_var then 
+            ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result)
+          else(
+            let free_var = if (List.mem name free_var) then free_var else name::free_var in
+            let expr = e_let_in (env,None) false false (
+              e_update (e_variable env) ("0") 
+              (e_update (e_accessor (e_variable env) "0") (Var.show name) (e_variable name))
+              )
+              let_result in
+            ok (true,(decl_var, free_var), e_let_in let_binder false  false rhs expr)
+          )
+        | E_variable name ->
+          if List.mem name decl_var || List.mem name free_var || Var.equal name env then 
+            ok (true,(decl_var, free_var), e_variable name)
+          else
+            ok (true,(decl_var, name::free_var), e_variable name)
+        | E_constant {cons_name=C_MAP_FOLD;arguments= _}
+        | E_constant {cons_name=C_SET_FOLD;arguments= _}
+        | E_constant {cons_name=C_LIST_FOLD;arguments= _} 
+        | E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp)
+      | _ -> ok (true,(decl_var, free_var),ass_exp)
+    )
+      (element_names,[])
+      for_body in
+  ok @@ captured_names
+
+and store_mutable_variable (free_vars : expression_variable list) =
+  if (List.length free_vars == 0) then
+    e_unit ()
+  else
+    let aux var = (Var.show var, e_variable var) in
+    e_record_ez (List.map aux free_vars)
+ 
+and restore_mutable_variable (expr : expression) (free_vars : expression_variable list) (env :expression_variable) =
+  let aux (f:expression -> expression) (ev:expression_variable) =
+    ok @@ fun expr -> f (e_let_in (ev,None) true false (e_accessor (e_variable env) (Var.show ev)) expr)
+  in
+  let%bind ef = bind_fold_list aux (fun e -> e) free_vars in
+  ok @@ fun expr'_opt -> match expr'_opt with
+  | None -> ok @@ e_let_in (env,None) false false expr (ef (e_skip ()))
+  | Some expr' -> ok @@ e_let_in (env,None) false false expr (ef expr')
+ 
+
+
 module Errors = struct
   let unsupported_cst_constr p =
     let title () = "" in
@@ -78,18 +161,6 @@ module Errors = struct
     ] in
     error ~data title message
 
-  let corner_case ~loc message =
-    let title () = "\nCorner case" in
-    let content () = "We do not have a good error message for this case. \
-                      We are striving find ways to better report them and \
-                      find the use-cases that generate them. \
-                      Please report this to the developers.\n" in
-    let data = [
-      ("location" , fun () -> loc) ;
-      ("message" , fun () -> message) ;
-    ] in
-    error ~data title content
-
   let unknown_predefined_type name =
     let title () = "\nType constants" in
     let message () =
@@ -196,16 +267,17 @@ let r_split = Location.r_split
    [return_statement] is used for non-let-in statements.
  *)
 
-let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt ->
+let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt ->
   match expr'_opt with
-  | None -> fail @@ corner_case ~loc:__LOC__ "missing return"
-  | Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr'
+  | None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ())
+  | Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr'
 
 let return_statement expr = ok @@ fun expr'_opt ->
   match expr'_opt with
   | None -> ok @@ expr
   | Some expr' -> ok @@ e_sequence expr expr'
 
+
 let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
   match t with
     TPar x -> simpl_type_expression x.value.inside
@@ -218,7 +290,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       let%bind (a , b) =
         let (a , _ , b) = x.value in
         bind_map_pair simpl_type_expression (a , b) in
-      ok @@ make_t @@ T_arrow (a , b)
+      ok @@ make_t @@ T_arrow {type1=a;type2=b}
     )
   | TApp x ->
       let (name, tuple) = x.value in
@@ -268,7 +340,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
   | [hd] -> simpl_type_expression hd
   | lst ->
       let%bind lst = bind_list @@ List.map simpl_type_expression lst in
-      ok @@ make_t @@ T_operator (TC_tuple lst)
+      ok @@ t_tuple lst
 
 let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
   let (p' , loc) = r_split p in
@@ -279,11 +351,11 @@ let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
   let path' =
     let aux (s:Raw.selection) =
       match s with
-      | FieldName property -> Access_record property.value
-      | Component index -> Access_tuple (Z.to_int (snd index.value))
+      | FieldName property -> property.value
+      | Component index -> (Z.to_string (snd index.value))
     in
     List.map aux @@ npseq_to_list path in
-  ok @@ e_accessor ~loc var path'
+  ok @@ List.fold_left (e_accessor ~loc) var path'
 
 
 let rec simpl_expression (t:Raw.expr) : expr result =
@@ -409,7 +481,11 @@ let rec simpl_expression (t:Raw.expr) : expr result =
       let%bind expr = simpl_expression c.test in
       let%bind match_true = simpl_expression c.ifso in
       let%bind match_false = simpl_expression c.ifnot in
-      return @@ e_matching expr ~loc (Match_bool {match_true; match_false})
+      let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in
+      let env = Var.fresh () in
+      let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in
+      return @@ match_expr
+
   | ECase c -> (
       let (c , loc) = r_split c in
       let%bind e = simpl_expression c.expr in
@@ -422,7 +498,10 @@ let rec simpl_expression (t:Raw.expr) : expr result =
         @@ List.map get_value
         @@ npseq_to_list c.cases.value in
       let%bind cases = simpl_cases lst in
-      return @@ e_matching ~loc e cases
+      let match_expr = e_matching ~loc e cases in
+      let env = Var.fresh () in
+      let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in
+      return @@ match_expr
     )
   | EMap (MapInj mi)  -> (
       let (mi , loc) = r_split mi in
@@ -471,7 +550,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
   let (name, path) = simpl_path u.record in
   let record = match path with
   | [] -> e_variable (Var.of_name name)
-  | _ -> e_accessor (e_variable (Var.of_name name)) path in
+  | _ -> e_accessor_list (e_variable (Var.of_name name)) path in 
   let updates = u.updates.value.ne_elements in
   let%bind updates' =
     let aux (f:Raw.field_path_assign Raw.reg) =
@@ -486,7 +565,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
       | [] -> failwith "error in parsing"
       | hd :: [] -> ok @@ e_update ~loc record hd expr
       | hd :: tl -> 
-        let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in
+        let%bind expr = (aux (e_accessor ~loc record hd) tl) in
         ok @@ e_update ~loc record hd expr 
     in
     aux ur path in
@@ -584,7 +663,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
       let name = x.name.value in
       let%bind t = simpl_type_expression x.var_type in
       let%bind expression = simpl_expression x.init in
-      return_let_in ~loc (Var.of_name name, Some t) false expression
+      return_let_in ~loc (Var.of_name name, Some t) false false expression
   | LocalConst x ->
       let (x , loc) = r_split x in
       let name = x.name.value in
@@ -596,7 +675,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
         | Some {value; _} ->
            npseq_to_list value.ne_elements
            |> List.exists (fun Region.{value; _} -> value = "\"inline\"")
-      in return_let_in ~loc (Var.of_name name, Some t) inline expression
+      in return_let_in ~loc (Var.of_name name, Some t) false inline expression
   | LocalFun f  ->
       let (f , loc) = r_split f in
       let%bind (binder, expr) = simpl_fun_decl ~loc f in
@@ -606,22 +685,22 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
         | Some {value; _} ->
            npseq_to_list value.ne_elements
            |> List.exists (fun Region.{value; _} -> value = "\"inline\"")
-      in return_let_in ~loc binder inline expr
+      in return_let_in ~loc binder false inline expr
 
 and simpl_param :
-      Raw.param_decl -> (expression_variable * type_expression) result =
+      Raw.param_decl -> (string * type_expression) result =
   fun t ->
   match t with
   | ParamConst c ->
       let c = c.value in
-      let type_name = Var.of_name c.var.value in
+      let param_name = c.var.value in
       let%bind type_expression = simpl_type_expression c.param_type in
-      ok (type_name , type_expression)
+      ok (param_name , type_expression)
   | ParamVar v ->
       let c = v.value in
-      let type_name = Var.of_name c.var.value in
+      let param_name = c.var.value in
       let%bind type_expression = simpl_type_expression c.param_type in
-      ok (type_name , type_expression)
+      ok (param_name , type_expression)
 
 and simpl_fun_decl :
       loc:_ -> Raw.fun_decl ->
@@ -652,10 +731,10 @@ and simpl_fun_decl :
        let%bind result =
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
-       let expression : expression = e_lambda ~loc binder (Some input_type)
+       let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
            (Some output_type) result in
        let type_annotation =
-         Some (make_t @@ T_arrow (input_type, output_type)) in
+         Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
        ok ((Var.of_name fun_name.value, type_annotation), expression)
      )
    | lst -> (
@@ -667,11 +746,11 @@ and simpl_fun_decl :
          let type_expression = t_tuple (List.map snd params) in
          (arguments_name , type_expression) in
        let%bind tpl_declarations =
-         let aux = fun i x ->
+         let aux = fun i (param, type_expr) ->
            let expr =
-             e_accessor (e_variable arguments_name) [Access_tuple i] in
-           let type_variable = Some (snd x) in
-           let ass = return_let_in (fst x , type_variable) inline expr in
+             e_accessor (e_variable arguments_name) (string_of_int i) in
+           let type_variable = Some type_expr in
+           let ass = return_let_in (Var.of_name param , type_variable) false inline expr in
            ass
          in
          bind_list @@ List.mapi aux params in
@@ -683,8 +762,8 @@ and simpl_fun_decl :
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
        let expression =
-         e_lambda ~loc binder (Some input_type) (Some output_type) result in
-       let type_annotation = Some (make_t @@ T_arrow (input_type, output_type)) in
+         e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
+       let type_annotation = Some (make_t @@ T_arrow {type1=input_type; type2=output_type}) in
        ok ((Var.of_name fun_name.value, type_annotation), expression)
      )
   )
@@ -706,11 +785,10 @@ and simpl_fun_expression :
        let%bind result =
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
-       let expression : expression = e_lambda ~loc binder (Some input_type)
+       let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
            (Some output_type) result in
-       let type_annotation =
-         Some (make_t @@ T_arrow (input_type, output_type)) in
-       ok (type_annotation, expression)
+       let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
+       ok (type_annotation , expression)
      )
    | lst -> (
        let lst = npseq_to_list lst in
@@ -721,11 +799,10 @@ and simpl_fun_expression :
          let type_expression = t_tuple (List.map snd params) in
          (arguments_name , type_expression) in
        let%bind tpl_declarations =
-         let aux = fun i x ->
-           let expr =
-             e_accessor (e_variable arguments_name) [Access_tuple i] in
-           let type_variable = Some (snd x) in
-           let ass = return_let_in (fst x , type_variable) false expr in
+         let aux = fun i (param, param_type) ->
+           let expr = e_accessor (e_variable arguments_name) (string_of_int i) in
+           let type_variable = Some param_type in
+           let ass = return_let_in (Var.of_name param , type_variable) false false expr in
            ass
          in
          bind_list @@ List.mapi aux params in
@@ -738,8 +815,8 @@ and simpl_fun_expression :
          bind_fold_right_list aux result body in
        let expression =
          e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
-       let type_annotation = Some (make_t @@ T_arrow (input_type, output_type)) in
-       ok (type_annotation, expression)
+       let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
+       ok (type_annotation , expression)
      )
   )
 
@@ -770,6 +847,35 @@ and simpl_statement_list statements =
       hook (simpl_data_declaration d :: acc) statements
   in bind_list @@ hook [] (List.rev statements)
 
+and get_case_variables (t:Raw.pattern) : expression_variable list result = 
+  match t with 
+    | PConstr PFalse _ 
+    | PConstr PTrue _ 
+    | PConstr PNone _ -> ok @@ [] 
+    | PConstr PSomeApp v -> (let (_,v) = v.value in get_case_variables (v.value.inside)) 
+    | PConstr PConstrApp v -> (
+      match v.value with
+      | constr, None -> ok @@ [ Var.of_name constr.value]
+      | constr, pat_opt ->
+        let%bind pat =
+          trace_option (unsupported_cst_constr t) @@
+          pat_opt in
+        let pat = npseq_to_list pat.value.inside in
+        let%bind var = bind_map_list get_case_variables pat in
+        ok @@ [Var.of_name constr.value ] @ (List.concat var)
+    )
+    | PList PNil _  -> ok @@ []
+    | PList PCons c -> (
+        match c.value with
+        | a, [(_, b)] ->
+            let%bind a = get_case_variables a in
+            let%bind b = get_case_variables b in
+            ok @@ a@b
+        | _ -> fail @@ unsupported_deep_list_patterns c
+    )
+    | PVar  v -> ok @@ [Var.of_name v.value] 
+    | p -> fail @@ unsupported_cst_constr p
+
 and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result =
   fun t ->
   match t with
@@ -799,19 +905,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       return_statement @@ e_skip ~loc ()
     )
   | Loop (While l) ->
-      let l = l.value in
-      let%bind cond = simpl_expression l.cond in
-      let%bind body = simpl_block l.block.value in
-      let%bind body = body None in
-      return_statement @@ e_loop cond body
-  | Loop (For (ForInt fi)) ->
+      simpl_while_loop l.value
+  | Loop (For (ForInt fi)) -> (
       let%bind loop = simpl_for_int fi.value in
-      let%bind loop = loop None in
-      return_statement @@ loop
+      ok loop
+  )
   | Loop (For (ForCollect fc)) ->
       let%bind loop = simpl_for_collect fc.value in
-      let%bind loop = loop None in
-      return_statement @@ loop
+      ok loop
   | Cond c -> (
       let (c , loc) = r_split c in
       let%bind expr = simpl_expression c.test in
@@ -833,9 +934,22 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
                 simpl_block value
             | ShortBlock {value; _} ->
                 simpl_statements @@ fst value.inside in
-      let%bind match_true = match_true None in
-      let%bind match_false = match_false None in
-      return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false})
+      let env = Var.fresh () in
+      
+      let%bind match_true' = match_true None in
+      let%bind match_false' = match_false None in
+      let%bind match_true  = match_true @@ Some (e_variable env) in
+      let%bind match_false = match_false @@ Some (e_variable env) in
+
+      let%bind ((_,free_vars_true), match_true) = repair_mutable_variable match_true [] env in
+      let%bind ((_,free_vars_false), match_false) = repair_mutable_variable match_false [] env in
+      let free_vars = free_vars_true @ free_vars_false in
+      if (List.length free_vars != 0) then 
+        let match_expr  = e_matching expr ~loc (Match_bool {match_true; match_false}) in
+        let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in
+        restore_mutable_variable return_expr free_vars env
+      else
+        return_statement @@ e_matching expr ~loc (Match_bool {match_true=match_true'; match_false=match_false'})
     )
   | Assign a -> (
       let (a , loc) = r_split a in
@@ -843,7 +957,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       match a.lhs with
         | Path path -> (
             let (name , path') = simpl_path path in
-            return_statement @@ e_assign ~loc name path' value_expr
+            let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
+            return_let_in let_binder mut inline rhs
           )
         | MapPath v -> (
             let v' = v.value in
@@ -856,14 +971,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
             in
             let%bind key_expr = simpl_expression v'.index.value.inside in
             let expr' = e_map_add key_expr value_expr map in
-            return_statement @@ e_assign ~loc varname path expr'
+            let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
+            return_let_in let_binder mut inline rhs  
           )
     )
   | CaseInstr c -> (
       let (c , loc) = r_split c in
       let%bind expr = simpl_expression c.expr in
-      let%bind cases =
-        let aux (x : Raw.if_clause Raw.case_clause Raw.reg) =
+      let env = Var.fresh () in
+      let%bind (fv,cases) =
+        let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) =
           let%bind case_clause =
             match x.value.rhs with
               ClauseInstr i ->
@@ -874,42 +991,43 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
                     simpl_block value
                 | ShortBlock {value; _} ->
                   simpl_statements @@ fst value.inside in
-          let%bind case_clause = case_clause None in
-          ok (x.value.pattern, case_clause) in
-        bind_list
-        @@ List.map aux
-        @@ npseq_to_list c.cases.value in
+          let%bind case_clause'= case_clause @@ None in
+          let%bind case_clause = case_clause @@ Some(e_variable env) in
+          let%bind case_vars   = get_case_variables x.value.pattern in
+          let%bind ((_,free_vars), case_clause) = repair_mutable_variable case_clause case_vars env in
+          ok (free_vars::fv,(x.value.pattern, case_clause, case_clause')) in
+        bind_fold_map_list aux [] (npseq_to_list c.cases.value) in
+      let free_vars = List.concat fv in
+      if (List.length free_vars == 0) then (
+        let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
         let%bind m = simpl_cases cases in
         return_statement @@ e_matching ~loc expr m
+      ) else (
+        let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
+        let%bind m = simpl_cases cases in
+        let match_expr = e_matching ~loc expr m in
+        let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in
+        restore_mutable_variable return_expr free_vars env
+      )
     )
   | RecordPatch r -> (
-      let r = r.value in
-      let (name , access_path) = simpl_path r.path in
-
-      let head, tail = r.record_inj.value.ne_elements in
-
-      let%bind tail' = bind_list
-        @@ List.map (fun (x: Raw.field_assign Region.reg) ->
-            let (x , loc) = r_split x in
-            let%bind e = simpl_expression x.field_expr
-            in ok (x.field_name.value, e , loc)
-          )
-        @@ List.map snd tail in
-
-      let%bind head' =
-        let (x , loc) = r_split head in
-        let%bind e = simpl_expression x.field_expr
-        in ok (x.field_name.value, e , loc) in
-
-      let%bind expr =
-        let aux = fun (access , v , loc) ->
-          e_assign ~loc name (access_path @ [Access_record access]) v in
-
-        let hd, tl = aux head', List.map aux tail' in
-        let aux acc cur = e_sequence acc cur in
-        ok @@ List.fold_left aux hd tl
+      let reg = r.region in
+      let (r,loc) = r_split r in
+      let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
+         {value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
+         region = fa.region}
       in
-      return_statement @@ expr
+      let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
+        value = Raw.map_ne_injection aux r.record_inj.value;
+        region=r.record_inj.region
+        } in
+      let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
+      let%bind expr = simpl_update {value=u;region=reg} in
+      let (name , access_path) = simpl_path r.path in
+      let loc = Some loc in
+      let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in
+      return_let_in binder mut inline rhs
+
   )
   | MapPatch patch -> (
       let (map_p, loc) = r_split patch in
@@ -923,16 +1041,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
             in ok @@ (key', value')
           )
         @@ npseq_to_list map_p.map_inj.value.ne_elements in
-      let expr =
       match inj with
-        | [] -> e_skip ~loc ()
+      | [] -> return_statement @@ e_skip ~loc ()
       | _ :: _ ->
         let assigns = List.fold_right
             (fun (key, value) map ->  (e_map_add key value map))
             inj
-              (e_accessor ~loc (e_variable (Var.of_name name)) access_path)
-          in e_assign ~loc name access_path assigns
-      in return_statement @@ expr
+            (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
+        in 
+        let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
+        return_let_in binder mut inline rhs
     )
   | SetPatch patch -> (
       let (setp, loc) = r_split patch in
@@ -941,15 +1059,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
         bind_list @@
         List.map simpl_expression @@
         npseq_to_list setp.set_inj.value.ne_elements in
-      let expr =
       match inj with
-        | [] -> e_skip ~loc ()
+      | [] -> return_statement @@ e_skip ~loc ()
       | _ :: _ ->
         let assigns = List.fold_right
           (fun hd s -> e_constant C_SET_ADD [hd ; s])
-            inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
-          e_assign ~loc name access_path assigns in
-      return_statement @@ expr
+          inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
+        let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
+        return_let_in binder mut inline rhs
     )
   | MapRemove r -> (
       let (v , loc) = r_split r in
@@ -963,7 +1080,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       in
       let%bind key' = simpl_expression key in
       let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
-      return_statement @@ e_assign ~loc varname path expr
+      let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
+      return_let_in binder mut inline rhs
     )
   | SetRemove r -> (
       let (set_rm, loc) = r_split r in
@@ -976,10 +1094,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       in
       let%bind removed' = simpl_expression set_rm.element in
       let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
-      return_statement @@ e_assign ~loc varname path expr
+      let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
+      return_let_in binder mut inline rhs
     )
 
-and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
+and simpl_path : Raw.path -> string * string list = fun p ->
   match p with
   | Raw.Name v -> (v.value , [])
   | Raw.Path p -> (
@@ -989,14 +1108,14 @@ and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
       let path' =
         let aux (s:Raw.selection) =
           match s with
-          | FieldName property -> Access_record property.value
-          | Component index -> Access_tuple (Z.to_int (snd index.value))
+          | FieldName property -> property.value
+          | Component index -> (Z.to_string (snd index.value))
         in
         List.map aux @@ npseq_to_list path in
       (var , path')
     )
 
-and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = fun t ->
+and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
   let open Raw in
   let get_var (t:Raw.pattern) =
     match t with
@@ -1105,223 +1224,108 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result =
 and simpl_block : Raw.block -> (_ -> expression result) result =
   fun t -> simpl_statements t.statements
 
+and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl ->
+  let env_rec = Var.fresh () in
+  let binder  = Var.fresh () in
+
+  let%bind cond = simpl_expression wl.cond in
+  let%bind for_body = simpl_block wl.block.value in
+
+  let ctrl = 
+    (e_variable binder)
+    in
+  let%bind for_body = for_body @@ Some( ctrl ) in
+  let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [] binder in
+
+  let aux name expr=
+    e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr
+  in
+  let init_rec = store_mutable_variable @@ captured_name_list in
+  let restore = fun expr -> List.fold_right aux captured_name_list expr in
+  let continue_expr = e_constant C_CONTINUE [for_body] in
+  let stop_expr = e_constant C_STOP [e_variable binder] in
+  let aux_func = e_cond cond continue_expr (stop_expr) in
+  let aux_func = (restore (aux_func)) in
+  let aux_func = e_lambda binder None None @@ aux_func in
+  let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
+  let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in
+  restore_mutable_variable return_expr captured_name_list env_rec 
+
+
 and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
-  (* cond part *)
-  let var = e_variable (Var.of_name fi.assign.value.name.value) in
+  let env_rec = Var.fresh () in
+  let binder  = Var.fresh () in
+  let name = fi.assign.value.name.value in
+  let it = Var.of_name name in
+  let var = e_variable it in
+  (*Make the cond and the step *)
   let%bind value = simpl_expression fi.assign.value.expr in
   let%bind bound = simpl_expression fi.bound in
-  let comp = e_annotation (e_constant C_LE [var ; bound]) t_bool
-  in
-  (* body part *)
-  let%bind body = simpl_block fi.block.value in
-  let%bind body = body None in
+  let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
   let step = e_int 1 in
-  let ctrl = e_assign
-    fi.assign.value.name.value [] (e_constant C_ADD [ var ; step ]) in
-  let rec add_to_seq expr = match expr.expression with
-    | E_sequence (_,a) -> add_to_seq a
-    | _ -> e_sequence body ctrl in
-  let body' = add_to_seq body in
-  let loop = e_loop comp body' in
-  return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) false value loop
+  let ctrl = 
+    e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ]) 
+    (e_let_in (binder, None) false false (e_update (e_variable binder) name var)
+    (e_variable binder))
+    in
+  (* Modify the body loop*)
+  let%bind for_body = simpl_block fi.block.value in
+  let%bind for_body = for_body @@ Some( ctrl ) in
+  let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [it] binder in
 
-(** simpl_for_collect
-  For loops over collections, like
+  let aux name expr=
+    e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr
+  in
 
-  ``` concrete syntax :
-  for x : int in set myset
-  begin
-    myint := myint + x ;
-    myst := myst ^ "to" ;
-  end
-  ```
+  (* restores the initial value of the free_var*)
+  let restore = fun expr -> List.fold_right aux captured_name_list expr in
 
-  are implemented using a MAP_FOLD, LIST_FOLD or SET_FOLD:
+  (*Prep the lambda for the fold*)
+  let continue_expr = e_constant C_CONTINUE [for_body] in
+  let stop_expr = e_constant C_STOP [e_variable binder] in
+  let aux_func = e_cond cond continue_expr (stop_expr) in
+  let aux_func = e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) name) (restore (aux_func)) in
+  let aux_func = e_lambda binder None None @@ aux_func in
 
-  ``` pseudo Ast_simplified
-  let #COMPILER#folded_record = list_fold(  mylist ,
-                                  record st = st; acc = acc; end;
-                                  lamby = fun arguments -> (
-                                      let #COMPILER#acc = arguments.0 in
-                                      let #COMPILER#elt_x = arguments.1 in
-                                      #COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt_x ;
-                                      #COMPILER#acc.myst  := #COMPILER#acc.myst ^ "to" ;
-                                      #COMPILER#acc
-                                  )
-                                ) in
-  {
-    myst  := #COMPILER#folded_record.myst ;
-    myint := #COMPILER#folded_record.myint ;
-  }
-  ```
+  (* Make the fold_while en precharge the vakye *)
+  let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
+  let init_rec = store_mutable_variable @@ it::captured_name_list in
+  let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in
+  let return_expr = e_let_in (it, Some t_int) false false value @@ return_expr in
+  restore_mutable_variable return_expr captured_name_list env_rec 
 
-  We are performing the following steps:
-    1) Simplifying the for body using ̀simpl_block`
-
-    2) Detect the free variables and build a list of their names
-       (myint and myst in the previous example)
-       Free variables are simply variables being assigned but not defined
-       locally.
-       Note:  In the case of a nested loops, assignements to a compiler
-              generated value (#COMPILER#acc) correspond to variables
-              that were already renamed in the inner loop.
-              e.g :
-              ```
-              #COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt_x ;
-              #COMPILER#acc.myst  := #COMPILER#acc.myst ^ "to" ;
-              ```
-              They must not be considered as free variables
-
-    3) Build the initial record (later passed as 2nd argument of
-      `MAP/SET/LIST_FOLD`) capturing the environment using the
-      free variables list of (2)
-
-    4) In the filtered body of (1), replace occurences:
-        - free variable of name X as rhs ==> accessor `#COMPILER#acc.X`
-        - free variable of name X as lhs ==> accessor `#COMPILER#acc.X`
-       And, in the case of a map:
-            - references to the iterated key   ==> variable `#COMPILER#elt_K`
-            - references to the iterated value ==> variable `#COMPILER#elt_V`
-            in the case of a set/list:
-            - references to the iterated value ==> variable `#COMPILER#elt_X`
-       Note: In the case of an inner loop capturing variable from an outer loop
-             the free variable name can be `#COMPILER#acc.Y` and because we do not
-             capture the accumulator record in the inner loop, we do not want to
-             generate `#COMPILER#acc.#COMPILER#acc.Y` but `#COMPILER#acc.Y`
-
-    5) Append the return value to the body
-
-    6) Prepend the declaration of the lambda arguments to the body which
-       is a serie of `let .. in`'s
-       Note that the parameter of the lambda ̀arguments` is a tree of
-       tuple holding:
-        * In the case of `list` or ̀set`:
-          ( folding record , current list/set element ) as
-          ( #COMPILER#acc  , #COMPILER#elt_X          )
-        * In the case of `map`:
-          ( folding record , current map key ,   current map value   ) as
-          ( #COMPILER#acc  , #COMPILER#elt_K ,   #COMPILER#elt_V     )
-       Note: X , K and V above have to be replaced with their given name
-
-    7) Build the lambda using the final body of (6)
-
-    8) Build a sequence of assignments for all the captured variables
-       to their new value, namely an access to the folded record
-       (#COMPILER#folded_record)
-
-    9) Attach the sequence of 8 to the ̀let .. in` declaration
-       of #COMPILER#folded_record
-
-**)
 and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
-  let elt_name = "#COMPILER#elt_"^fc.var.value in
-  let elt_v_name = match fc.bind_to with
-    | Some v -> "#COMPILER#elt_"^(snd v).value
-    | None -> "#COMPILER#elt_unused" in
-  let element_names = ok @@ match fc.bind_to with
+  let _elt_name = fc.var.value in
+  let binder = Var.of_name "arguments" in
+  let%bind element_names = ok @@ match fc.bind_to with
     | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
     | None -> [Var.of_name fc.var.value] in
-  (* STEP 1 *)
+  
+  let env = Var.fresh () in
   let%bind for_body = simpl_block fc.block.value in
-  let%bind for_body = for_body None in
-  (* STEP 2 *)
-  let%bind local_decl_name_list = bind_concat (detect_local_declarations for_body) element_names in
-  let%bind captured_name_list = detect_free_variables for_body local_decl_name_list in
-  (* STEP 3 *)
-  let add_to_record (prev: expression SMap.t) (captured_name: string) =
-    SMap.add captured_name (e_variable (Var.of_name captured_name)) prev in
-  let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in
-  (* STEP 4 *)
-  let replace exp =
-    match exp.expression with
-    (* replace references to fold accumulator as lhs *)
-    | E_assign ( name , path , expr ) -> (
-      if (List.mem name local_decl_name_list ) then
-        ok @@ exp
-      else
-      let name = Var.to_name name in
-        let path' = List.filter
-          ( fun el ->
-            match el with
-            | Access_record name -> not @@ is_compiler_generated (Var.of_name name)
-            | _ -> true )
-          ((Access_record name)::path) in
-        ok @@ e_assign "#COMPILER#acc" path' expr )
-    | E_variable name -> (
-      let name = Var.to_name name in
-      if (List.mem name captured_name_list) then
-        (* replace references to fold accumulator as rhs *)
-        ok @@ e_accessor (e_variable (Var.of_name "#COMPILER#acc")) [Access_record name] (* TODO fresh *)
-      else match fc.collection with
-      (* loop on map *)
-      | Map _ ->
-        let k' = e_variable (Var.of_name elt_name) in
-        if ( name = fc.var.value ) then
-          ok @@ k' (* replace references to the the key *)
-        else (
-          match fc.bind_to with
-          | Some (_,v) ->
-            let v' = e_variable (Var.of_name elt_v_name) in
-            if ( name = v.value ) then
-              ok @@ v' (* replace references to the the value *)
-            else ok @@ exp
-          | None -> ok @@ exp
-      )
-      (* loop on set or list *)
-      | (Set _ | List _) ->
-        if (name = fc.var.value ) then
-          (* replace references to the collection element *)
-          ok @@ (e_variable (Var.of_name elt_name))
-        else ok @@ exp
-    )
-    | _ -> ok @@ exp in
-  let%bind for_body = Self_ast_simplified.map_expression replace for_body in
-  (* STEP 5 *)
-  let rec add_return (expr : expression) = match expr.expression with
-    | E_sequence (a,b) -> e_sequence a (add_return b)
-    | _  -> (* TODO fresh *)
-       e_sequence expr (e_variable (Var.of_name "#COMPILER#acc")) in
-  let for_body = add_return for_body in
-  (* STEP 6 *)
-  let for_body =
-    let ( arg_access: Types.access_path -> expression ) =
-      e_accessor (e_variable (Var.of_name "arguments")) in (* TODO fresh *)
-    ( match fc.collection with
-      | Map _ ->
-        let acc          = arg_access [Access_tuple 0 ] in
-        let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in
-        let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in
-        e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *)
-        e_let_in (Var.of_name elt_name, None) false collec_elt_v @@
-        e_let_in (Var.of_name elt_v_name, None) false collec_elt_k (for_body)
-      | _ ->
-        let acc        = arg_access [Access_tuple 0] in
-        let collec_elt = arg_access [Access_tuple 1] in
-        e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *)
-        e_let_in (Var.of_name elt_name, None) false collec_elt (for_body)
-    ) in
-  (* STEP 7 *)
+  let%bind _for_body' = for_body None in
+  let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in
+  let%bind ((_,free_vars), for_body) = repair_mutable_variable_for_collect for_body element_names binder in
+
+  let init_record = store_mutable_variable free_vars in
   let%bind collect = simpl_expression fc.expr in
-  let lambda = e_lambda (Var.of_name "arguments") None None for_body in
+  let aux name expr=
+    e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr
+  in
+  let restore = fun expr -> List.fold_right aux free_vars expr in
+  let restore = match fc.collection with
+    | Map _ -> (match fc.bind_to with 
+      | Some v -> fun expr -> restore (e_let_in (Var.of_name  fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") 
+                                    (e_let_in (Var.of_name (snd v).value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "1") expr))
+      | None -> fun expr -> restore (e_let_in (Var.of_name  fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") expr) 
+    )
+    | _ -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_variable binder) "1") expr)
+  in
+  let lambda = e_lambda binder None None (restore for_body) in
   let op_name = match fc.collection with
    | Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in
   let fold = e_constant op_name [lambda; collect ; init_record] in
-  (* STEP 8 *)
-  let assign_back (prev : expression option) (captured_varname : string) : expression option =
-    let access = (* TODO fresh *)
-      e_accessor (e_variable (Var.of_name "#COMPILER#folded_record"))
-      [Access_record captured_varname] in
-    let assign = e_assign captured_varname [] access in
-    match prev with
-    | None -> Some assign
-    | Some p -> Some (e_sequence p assign) in
-  let reassign_sequence = List.fold_left assign_back None captured_name_list in
-  (* STEP 9 *)
-  let final_sequence = match reassign_sequence with
-    (* None case means that no variables were captured *)
-    | None -> e_skip ()
-    | Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) false fold seq in (* TODO fresh *)
-  return_statement @@ final_sequence
+  restore_mutable_variable fold free_vars env
 
 and simpl_declaration_list declarations :
   Ast_simplified.declaration Location.wrap list result =

src/passes/3-self_ast_simplified/helpers.ml

@@ -1,13 +1,14 @@
 open Ast_simplified
 open Trace
+open Stage_common.Helpers
 
 type 'a folder = 'a -> expression -> 'a result
 let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
-  match e.expression with
+  match e.expression_content with
   | E_literal _ | E_variable _ | E_skip -> ok init'
-  | E_list lst | E_set lst | E_tuple lst | E_constant (_ , lst) -> (
+  | E_list lst | E_set lst | E_constant {arguments=lst} -> (
     let%bind res = bind_fold_list self init' lst in
     ok res
   )
@@ -15,20 +16,24 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
     let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
     ok res
   )
-  | E_look_up ab | E_sequence ab | E_loop ab | E_application ab -> (
+  | E_look_up ab ->
+      let%bind res = bind_fold_pair self init' ab in
+      ok res
+  | E_loop {condition;body} ->
+      let ab = (condition,body) in 
+      let%bind res = bind_fold_pair self init' ab in
+      ok res
+  | E_application {expr1;expr2} -> (
+      let ab = (expr1,expr2) in
       let%bind res = bind_fold_pair self init' ab in
       ok res
     )
   | E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e }
-  | E_ascription (e , _) | E_constructor (_ , e) -> (
+  | E_ascription {anno_expr=e; _} | E_constructor {element=e} -> (
       let%bind res = self init' e in
       ok res
     )
-  | E_assign (_ , _path , e) | E_accessor (e , _path) -> (
-      let%bind res = self init' e in
-      ok res
-    )
-  | E_matching (e , cases) -> (
+  | E_matching {matchee=e; cases} -> (
       let%bind res = self init' e in
       let%bind res = fold_cases f res cases in
       ok res
@@ -41,14 +46,18 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
     let%bind res = bind_fold_lmap aux (ok init') m in
     ok res
   )
-  | E_update {record;update=(_,expr)} -> (
+  | E_record_update {record;update} -> (
     let%bind res = self init' record in
-    let%bind res = fold_expression self res expr in
+    let%bind res = fold_expression self res update in
     ok res 
   )
-  | E_let_in { binder = _ ; rhs ; result } -> (
+  | E_record_accessor {expr} -> (
+     let%bind res = self init' expr in
+     ok res
+    )
+  | E_let_in { let_binder = _ ; rhs ; let_result } -> (
       let%bind res = self init' rhs in
-      let%bind res = self res result in
+      let%bind res = self res let_result in
       ok res
     )
 
@@ -85,8 +94,8 @@ type mapper = expression -> expression result
 let rec map_expression : mapper -> expression -> expression result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
-  let return expression = ok { e' with expression } in
-  match e'.expression with
+  let return expression_content = ok { e' with expression_content } in
+  match e'.expression_content with
   | E_list lst -> (
     let%bind lst' = bind_map_list self lst in
     return @@ E_list lst'
@@ -103,68 +112,58 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
     let%bind lst' = bind_map_list (bind_map_pair self) lst in
     return @@ E_big_map lst'
   )
-  | E_sequence ab -> (
-      let%bind ab' = bind_map_pair self ab in
-      return @@ E_sequence ab'
-    )
   | E_look_up ab -> (
       let%bind ab' = bind_map_pair self ab in
       return @@ E_look_up ab'
     )
-  | E_loop ab -> (
-      let%bind ab' = bind_map_pair self ab in
-      return @@ E_loop ab'
+  | E_loop {condition;body} -> (
+      let ab = (condition,body) in
+      let%bind (a,b) = bind_map_pair self ab in
+      return @@ E_loop {condition = a; body = b}
     )
-  | E_ascription (e , t) -> (
-      let%bind e' = self e in
-      return @@ E_ascription (e' , t)
+  | E_ascription ascr -> (
+      let%bind e' = self ascr.anno_expr in
+      return @@ E_ascription {ascr with anno_expr=e'}
     )
-  | E_assign (name , path , e) -> (
-      let%bind e' = self e in
-      return @@ E_assign (name , path , e')
-    )
-  | E_matching (e , cases) -> (
+  | E_matching {matchee=e;cases} -> (
       let%bind e' = self e in
       let%bind cases' = map_cases f cases in
-      return @@ E_matching (e' , cases')
+      return @@ E_matching {matchee=e';cases=cases'}
     )
-  | E_accessor (e , path) -> (
-      let%bind e' = self e in
-      return @@ E_accessor (e' , path)
+  | E_record_accessor acc -> (
+      let%bind e' = self acc.expr in
+      return @@ E_record_accessor {acc with expr = e'}
     )
   | E_record m -> (
     let%bind m' = bind_map_lmap self m in
     return @@ E_record m'
   )
-  | E_update {record; update=(l,expr)} -> (
+  | E_record_update {record; path; update} -> (
     let%bind record = self record in
-    let%bind expr = self expr in
-    return @@ E_update {record;update=(l,expr)}
+    let%bind update = self update in
+    return @@ E_record_update {record;path;update}
   )
-  | E_constructor (name , e) -> (
-      let%bind e' = self e in
-      return @@ E_constructor (name , e')
+  | E_constructor c -> (
+      let%bind e' = self c.element in
+      return @@ E_constructor {c with element = e'}
   )
-  | E_tuple lst -> (
-      let%bind lst' = bind_map_list self lst in
-      return @@ E_tuple lst'
+  | E_application {expr1;expr2} -> (
+      let ab = (expr1,expr2) in
+      let%bind (a,b) = bind_map_pair self ab in
+      return @@ E_application {expr1=a;expr2=b}
     )
-  | E_application ab -> (
-      let%bind ab' = bind_map_pair self ab in
-      return @@ E_application ab'
-    )
-  | E_let_in { binder ; rhs ; result; inline } -> (
+  | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
       let%bind rhs = self rhs in
-      let%bind result = self result in
-      return @@ E_let_in { binder ; rhs ; result; inline }
+      let%bind let_result = self let_result in
+      return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline }
     )
   | E_lambda { binder ; input_type ; output_type ; result } -> (
       let%bind result = self result in
       return @@ E_lambda { binder ; input_type ; output_type ; result }
     )
-  | E_constant (name , lst) -> (
-      let%bind lst' = bind_map_list self lst in
-      return @@ E_constant (name , lst')
+  | E_constant c -> (
+      let%bind args = bind_map_list self c.arguments in
+      return @@ E_constant {c with arguments=args}
     )
   | E_literal _ | E_variable _ | E_skip as e' -> return e'
 
@@ -209,3 +208,113 @@ and map_program : mapper -> program -> program result = fun m p ->
     | Declaration_type _ -> ok x
   in
   bind_map_list (bind_map_location aux) p
+
+type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
+let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
+  let self = fold_map_expression f in
+  let%bind (continue, init',e') = f a e in
+  if (not continue) then ok(init',e')
+  else
+  let return expression_content = { e' with expression_content } in
+  match e'.expression_content with
+  | E_list lst -> (
+    let%bind (res, lst') = bind_fold_map_list self init' lst in
+    ok (res, return @@ E_list lst')
+  )
+  | E_set lst -> (
+    let%bind (res, lst') = bind_fold_map_list self init' lst in
+    ok (res, return @@ E_set lst')
+  )
+  | E_map lst -> (
+    let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
+    ok (res, return @@ E_map lst')
+  )
+  | E_big_map lst -> (
+    let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
+    ok (res, return @@ E_big_map lst')
+  )
+  | E_look_up ab -> (
+      let%bind (res, ab') = bind_fold_map_pair self init' ab in
+      ok (res, return @@ E_look_up ab')
+    )
+  | E_loop {condition;body} -> (
+      let ab = (condition,body) in
+      let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
+      ok (res, return @@ E_loop {condition = a; body = b})
+    )
+  | E_ascription ascr -> (
+      let%bind (res,e') = self init' ascr.anno_expr in
+      ok (res, return @@ E_ascription {ascr with anno_expr=e'})
+    )
+  | E_matching {matchee=e;cases} -> (
+      let%bind (res, e') = self init' e in
+      let%bind (res,cases') = fold_map_cases f res cases in
+      ok (res, return @@ E_matching {matchee=e';cases=cases'})
+    )
+  | E_record_accessor acc -> (
+      let%bind (res, e') = self init' acc.expr in
+      ok (res, return @@ E_record_accessor {acc with expr = e'})
+    )
+  | E_record m -> (
+    let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
+    let m' = LMap.of_list lst' in
+    ok (res, return @@ E_record m')
+  )
+  | E_record_update {record; path; update} -> (
+    let%bind (res, record) = self init' record in
+    let%bind (res, update) = self res update in
+    ok (res, return @@ E_record_update {record;path;update})
+  )
+  | E_constructor c -> (
+      let%bind (res,e') = self init' c.element in
+      ok (res, return @@ E_constructor {c with element = e'})
+  )
+  | E_application {expr1;expr2} -> (
+      let ab = (expr1,expr2) in
+      let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
+      ok (res, return @@ E_application {expr1=a;expr2=b})
+    )
+  | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
+      let%bind (res,rhs) = self init' rhs in
+      let%bind (res,let_result) = self res let_result in
+      ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline })
+    )
+  | E_lambda { binder ; input_type ; output_type ; result } -> (
+      let%bind (res,result) = self init' result in
+      ok ( res, return @@ E_lambda { binder ; input_type ; output_type ; result })
+    )
+  | E_constant c -> (
+      let%bind (res,args) = bind_fold_map_list self init' c.arguments in
+      ok (res, return @@ E_constant {c with arguments=args})
+    )
+  | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e')
+
+and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
+  match m with
+  | Match_bool { match_true ; match_false } -> (
+      let%bind (init, match_true) = fold_map_expression f init match_true in
+      let%bind (init, match_false) = fold_map_expression f init match_false in
+      ok @@ (init, Match_bool { match_true ; match_false })
+    )
+  | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
+      let%bind (init, match_nil) = fold_map_expression f init match_nil in
+      let%bind (init, cons) = fold_map_expression f init cons in
+      ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
+    )
+  | Match_option { match_none ; match_some = (name , some, _) } -> (
+      let%bind (init, match_none) = fold_map_expression f init match_none in
+      let%bind (init, some) = fold_map_expression f init some in
+      ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
+    )
+  | Match_tuple ((names , e), _) -> (
+      let%bind (init, e') = fold_map_expression f init e in
+      ok @@ (init, Match_tuple ((names , e'), []))
+    )
+  | Match_variant (lst, _) -> (
+      let aux init ((a , b) , e) =
+        let%bind (init,e') = fold_map_expression f init e in
+        ok (init, ((a , b) , e'))
+      in
+      let%bind (init,lst') = bind_fold_map_list aux init lst in
+      ok @@ (init, Match_variant (lst', ()))
+    )  

src/passes/3-self_ast_simplified/literals.ml

@@ -52,8 +52,8 @@ end
 open Errors
 
 let peephole_expression : expression -> expression result = fun e ->
-  let return expression = ok { e with expression } in
-  match e.expression with
+  let return expression_content = ok { e with expression_content } in
+  match e.expression_content with
   | E_literal (Literal_key_hash s) as l -> (
     let open Tezos_crypto in
     let%bind (_pkh:Crypto.Signature.public_key_hash) =
@@ -82,18 +82,18 @@ let peephole_expression : expression -> expression result = fun e ->
       Signature.Public_key.of_b58check s in
     return l
     )
-  | E_constant (C_BIG_MAP_LITERAL as cst, lst) -> (
+  | E_constant {cons_name=C_BIG_MAP_LITERAL as cst; arguments=lst} -> (
       let%bind elt =
         trace_option (bad_single_arity cst e.location) @@
         List.to_singleton lst
       in
       let%bind lst =
         trace_strong (bad_map_param_type cst e.location) @@
-        get_e_list elt.expression
+        get_e_list elt.expression_content
       in
-      let aux = fun (e' : expression) ->
+      let aux = fun (e : expression) ->
         trace_strong (bad_map_param_type cst e.location) @@
-        let%bind tpl = get_e_tuple e'.expression in
+        let%bind tpl = get_e_tuple e.expression_content in
         let%bind (a , b) =
           trace_option (simple_error "of pairs") @@
           List.to_pair tpl
@@ -103,18 +103,18 @@ let peephole_expression : expression -> expression result = fun e ->
       let%bind pairs = bind_map_list aux lst in
       return @@ E_big_map pairs
     )
-  | E_constant (C_MAP_LITERAL as cst, lst) -> (
+  | E_constant {cons_name=C_MAP_LITERAL as cst; arguments=lst} -> (
       let%bind elt =
         trace_option (bad_single_arity cst e.location) @@
         List.to_singleton lst
       in
       let%bind lst =
         trace_strong (bad_map_param_type cst e.location) @@
-        get_e_list elt.expression
+        get_e_list elt.expression_content
       in
-      let aux = fun (e' : expression) ->
+      let aux = fun (e : expression) ->
         trace_strong (bad_map_param_type cst e.location) @@
-        let%bind tpl = get_e_tuple e'.expression in
+        let%bind tpl = get_e_tuple e.expression_content in
         let%bind (a , b) =
           trace_option (simple_error "of pairs") @@
           List.to_pair tpl
@@ -124,32 +124,33 @@ let peephole_expression : expression -> expression result = fun e ->
       let%bind pairs = bind_map_list aux lst in
       return @@ E_map pairs
     )
-  | E_constant (C_BIG_MAP_EMPTY as cst, lst) -> (
+  | E_constant {cons_name=C_BIG_MAP_EMPTY as cst; arguments=lst} -> (
       let%bind () =
         trace_strong (bad_empty_arity cst e.location) @@
         Assert.assert_list_empty lst
       in
       return @@ E_big_map []
     )
-  | E_constant (C_MAP_EMPTY as cst, lst) -> (
+  | E_constant {cons_name=C_MAP_EMPTY as cst; arguments=lst} -> (
       let%bind () =
         trace_strong (bad_empty_arity cst e.location) @@
         Assert.assert_list_empty lst
       in
       return @@ E_map []
     )
-  | E_constant (C_SET_LITERAL as cst, lst) -> (
+
+  | E_constant {cons_name=C_SET_LITERAL as cst; arguments=lst} -> (
       let%bind elt =
         trace_option (bad_single_arity cst e.location) @@
         List.to_singleton lst
       in
       let%bind lst =
         trace_strong (bad_set_param_type cst e.location) @@
-        get_e_list elt.expression
+        get_e_list elt.expression_content
       in
       return @@ E_set lst
     )
-  | E_constant (C_SET_EMPTY as cst, lst) -> (
+  | E_constant {cons_name=C_SET_EMPTY as cst; arguments=lst} -> (
       let%bind () =
         trace_strong (bad_empty_arity cst e.location) @@
         Assert.assert_list_empty lst

src/passes/3-self_ast_simplified/none_variant.ml

@@ -2,8 +2,8 @@ open Ast_simplified
 open Trace
 
 let peephole_expression : expression -> expression result = fun e ->
-  let return expression = ok { e with expression } in
-  match e.expression with
-  | E_constructor (Constructor "Some" , e) -> return @@ E_constant (C_SOME , [ e ])
-  | E_constructor (Constructor "None" , _) -> return @@ E_constant (C_NONE , [ ])
+  let return expression_content = ok { e with expression_content } in
+  match e.expression_content with
+  | E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]}
+  | E_constructor {constructor=Constructor "None"; _} -> return @@ E_constant {cons_name=C_NONE ; arguments=[]}
   | e -> return e

src/passes/3-self_ast_simplified/self_ast_simplified.ml

@@ -17,3 +17,5 @@ let all_expression =
 let map_expression = Helpers.map_expression
 
 let fold_expression = Helpers.fold_expression
+
+let fold_map_expression = Helpers.fold_map_expression

src/passes/3-self_ast_simplified/tezos_type_annotation.ml

@@ -13,10 +13,10 @@ end
 open Errors
 
 let peephole_expression : expression -> expression result = fun e ->
-  let return expression = ok { e with expression } in
-  match e.expression with
-  | E_ascription (e' , t) as e -> (
-      match (e'.expression , t.type_expression') with
+  let return expression_content = ok { e with expression_content } in
+  match e.expression_content with
+  | E_ascription {anno_expr=e'; type_annotation=t} as e -> (
+      match (e'.expression_content , t.type_content) with
       | (E_literal (Literal_string s) , T_constant (TC_key_hash)) -> return @@ E_literal (Literal_key_hash s)
       | (E_literal (Literal_string s) , T_constant (TC_signature)) -> return @@ E_literal (Literal_signature s)
       | (E_literal (Literal_string s) , T_constant (TC_key)) -> return @@ E_literal (Literal_key s)

src/passes/4-typer-new/PP.ml

@@ -7,7 +7,6 @@ let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf ->
     let ct = match c_tag with
       | Solver.Core.C_arrow     -> "arrow"
       | Solver.Core.C_option    -> "option"
-      | Solver.Core.C_tuple     -> "tuple"
       | Solver.Core.C_record    -> failwith "record"
       | Solver.Core.C_variant   -> failwith "variant"
       | Solver.Core.C_map       -> "map"

src/passes/4-typer-new/solver.ml

@@ -9,13 +9,13 @@ module Wrap = struct
 
   module Errors = struct
 
-    let unknown_type_constructor (ctor : string) (te : T.type_value) () =
+    let unknown_type_constructor (ctor : string) (te : T.type_expression) () =
       let title = (thunk "unknown type constructor") in
       (* TODO: sanitize the "ctor" argument before displaying it. *)
       let message () = ctor in
       let data = [
         ("ctor" , fun () -> ctor) ;
-        ("expression" , fun () -> Format.asprintf "%a"  T.PP.type_value te) ;
+        ("expression" , fun () -> Format.asprintf "%a"  T.PP.type_expression te) ;
         (* ("location" , fun () -> Format.asprintf "%a" Location.pp te.location) *) (* TODO *)
       ] in
       error ~data title message ()
@@ -32,16 +32,17 @@ module Wrap = struct
   (*   let%bind state' = add_type state t in *)
   (*   return expr state' in *)
 
-  let rec type_expression_to_type_value : T.type_value -> O.type_value = fun te ->
-    match te.type_value' with
+  let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun te ->
+    match te.type_content with
     | T_sum kvmap ->
       let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
       P_constant (C_variant, T.CMap.to_list @@ T.CMap.map type_expression_to_type_value kvmap)
     | T_record kvmap ->
       let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in
       P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap)
-    | T_arrow (arg , ret) ->
-      P_constant (C_arrow, List.map type_expression_to_type_value [ arg ; ret ])
+    | T_arrow {type1;type2} ->
+      P_constant (C_arrow, List.map type_expression_to_type_value [ type1 ; type2 ])
+
     | T_variable (type_name) -> P_variable type_name
     | T_constant (type_name) ->
       let csttag = Core.(match type_name with
@@ -58,7 +59,8 @@ module Wrap = struct
           | TC_key       -> C_key
           | TC_signature -> C_signature
           | TC_operation -> C_operation
-          | TC_chain_id  -> C_unit    (* TODO : replace  with chain_id*)
+          | TC_chain_id  -> C_unit    (* TODO : replace  with chain_id *)
+          | TC_void      -> C_unit    (* TODO : replace with void *)
       )
       in
       P_constant (csttag, [])
@@ -68,25 +70,24 @@ module Wrap = struct
           | TC_set s               -> (C_set, [s])
           | TC_map ( k , v )       -> (C_map, [k;v])
           | TC_big_map ( k , v)    -> (C_big_map, [k;v])
+          | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
           | TC_list l              -> (C_list, [l])
           | TC_contract c          -> (C_contract, [c])
-          | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
-          | TC_tuple lst           -> (C_tuple, lst)
       )
       in
       P_constant (csttag, List.map type_expression_to_type_value args)
 
   let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te ->
-    match te.type_expression' with
+    match te.type_content with
     | T_sum kvmap ->
       let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
       P_constant (C_variant, I.CMap.to_list @@ I.CMap.map type_expression_to_type_value_copypasted kvmap)
     | T_record kvmap ->
       let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in
       P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap)
-    | T_arrow (arg , ret) ->
-      P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ arg ; ret ])
-    | T_variable type_name -> P_variable type_name
+    | T_arrow {type1;type2} ->
+      P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ type1 ; type2 ])
+    | T_variable type_name -> P_variable (type_name) (* eird stuff*)
     | T_constant (type_name) ->
       let csttag = Core.(match type_name with
           | TC_unit   -> C_unit
@@ -104,7 +105,6 @@ module Wrap = struct
           | TC_big_map  ( k , v )  -> (C_big_map, [k;v])
           | TC_contract c          -> (C_contract, [c])
           | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
-          | TC_tuple lst           -> (C_tuple, lst)
       )
       in
       P_constant (csttag, List.map type_expression_to_type_value_copypasted args)
@@ -113,12 +113,12 @@ module Wrap = struct
     let type_name = Core.fresh_type_variable () in
     [] , type_name
 
-  let variable : I.expression_variable -> T.type_value -> (constraints * T.type_variable) = fun _name expr ->
+  let variable : I.expression_variable -> T.type_expression -> (constraints * T.type_variable) = fun _name expr ->
     let pattern = type_expression_to_type_value expr in
     let type_name = Core.fresh_type_variable () in
     [C_equation (P_variable (type_name) , pattern)] , type_name
 
-  let literal : T.type_value -> (constraints * T.type_variable) = fun t ->
+  let literal : T.type_expression -> (constraints * T.type_variable) = fun t ->
     let pattern = type_expression_to_type_value t in
     let type_name = Core.fresh_type_variable () in
     [C_equation (P_variable (type_name) , pattern)] , type_name
@@ -135,9 +135,9 @@ module Wrap = struct
     [C_equation (P_variable (type_name) , pattern)] , type_name
    *)
 
-  let tuple : T.type_value list -> (constraints * T.type_variable) = fun tys ->
+  let tuple : T.type_expression list -> (constraints * T.type_variable) = fun tys ->
     let patterns = List.map type_expression_to_type_value tys in
-    let pattern = O.(P_constant (C_tuple , patterns)) in
+    let pattern = O.(P_constant (C_record , patterns)) in
     let type_name = Core.fresh_type_variable () in
     [C_equation (P_variable (type_name) , pattern)] , type_name
 
@@ -165,16 +165,13 @@ module Wrap = struct
   end
 
   (* TODO: I think we should take an I.expression for the base+label *)
-  let access_label ~(base : T.type_value) ~(label : O.accessor) : (constraints * T.type_variable) =
+  let access_label ~(base : T.type_expression) ~(label : O.accessor) : (constraints * T.type_variable) =
     let base' = type_expression_to_type_value base in
     let expr_type = Core.fresh_type_variable () in
     [O.C_access_label (base' , label , expr_type)] , expr_type
 
-  let access_int ~base ~index = access_label ~base ~label:(L_int index)
-  let access_string ~base ~property = access_label ~base ~label:(L_string property)
-
   let constructor
-    : T.type_value -> T.type_value -> T.type_value -> (constraints * T.type_variable)
+    : T.type_expression -> T.type_expression -> T.type_expression -> (constraints * T.type_variable)
     = fun t_arg c_arg sum ->
       let t_arg = type_expression_to_type_value t_arg in
       let c_arg = type_expression_to_type_value c_arg in
@@ -185,12 +182,12 @@ module Wrap = struct
         C_equation (t_arg , c_arg)
       ] , whole_expr
 
-  let record : T.type_value I.label_map -> (constraints * T.type_variable) = fun fields ->
+  let record : T.type_expression T.label_map -> (constraints * T.type_variable) = fun fields ->
     let record_type = type_expression_to_type_value (T.t_record fields ()) in
     let whole_expr = Core.fresh_type_variable () in
     [C_equation (P_variable whole_expr , record_type)] , whole_expr
 
-  let collection : O.constant_tag -> T.type_value list -> (constraints * T.type_variable) =
+  let collection : O.constant_tag -> T.type_expression list -> (constraints * T.type_variable) =
     fun ctor element_tys ->
       let elttype = O.P_variable (Core.fresh_type_variable ()) in
       let aux elt =
@@ -205,7 +202,7 @@ module Wrap = struct
   let list = collection O.C_list
   let set  = collection O.C_set
 
-  let map : (T.type_value * T.type_value) list -> (constraints * T.type_variable) =
+  let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
     fun kv_tys ->
       let k_type = O.P_variable (Core.fresh_type_variable ()) in
       let v_type = O.P_variable (Core.fresh_type_variable ()) in
@@ -222,7 +219,7 @@ module Wrap = struct
         C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type]))
       ] @ equations_k @ equations_v , whole_expr
 
-  let big_map : (T.type_value * T.type_value) list -> (constraints * T.type_variable) =
+  let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
     fun kv_tys ->
       let k_type = O.P_variable (Core.fresh_type_variable ()) in
       let v_type = O.P_variable (Core.fresh_type_variable ()) in
@@ -241,7 +238,7 @@ module Wrap = struct
         C_equation (P_variable whole_expr , O.P_constant (C_big_map , [k_type ; v_type]))
       ] @ equations_k @ equations_v , whole_expr
 
-  let application : T.type_value -> T.type_value -> (constraints * T.type_variable) =
+  let application : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
     fun f arg ->
       let whole_expr = Core.fresh_type_variable () in
       let f'   = type_expression_to_type_value f in
@@ -250,7 +247,7 @@ module Wrap = struct
         C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr]))
       ] , whole_expr
 
-  let look_up : T.type_value -> T.type_value -> (constraints * T.type_variable) =
+  let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
     fun ds ind ->
       let ds'  = type_expression_to_type_value ds in
       let ind' = type_expression_to_type_value ind in
@@ -261,7 +258,7 @@ module Wrap = struct
         C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v]))
       ] , whole_expr
 
-  let sequence : T.type_value -> T.type_value -> (constraints * T.type_variable) =
+  let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
     fun a b ->
       let a' = type_expression_to_type_value a in
       let b' = type_expression_to_type_value b in
@@ -271,7 +268,7 @@ module Wrap = struct
         C_equation (b' , P_variable whole_expr)
       ] , whole_expr
 
-  let loop : T.type_value -> T.type_value -> (constraints * T.type_variable) =
+  let loop : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
     fun expr body ->
       let expr' = type_expression_to_type_value expr in
       let body' = type_expression_to_type_value body in
@@ -282,7 +279,7 @@ module Wrap = struct
         C_equation (P_variable whole_expr , P_constant (C_unit , []))
       ] , whole_expr
 
-  let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * T.type_variable) =
+  let let_in : T.type_expression -> T.type_expression option -> T.type_expression -> (constraints * T.type_variable) =
     fun rhs rhs_tv_opt result ->
       let rhs'        = type_expression_to_type_value rhs in
       let result'     = type_expression_to_type_value result in
@@ -294,7 +291,7 @@ module Wrap = struct
         C_equation (result' , P_variable whole_expr)
       ] @ rhs_tv_opt', whole_expr
 
-  let assign : T.type_value -> T.type_value -> (constraints * T.type_variable) =
+  let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
     fun v e ->
       let v' = type_expression_to_type_value v in
       let e' = type_expression_to_type_value e in
@@ -304,7 +301,7 @@ module Wrap = struct
         C_equation (P_variable whole_expr , P_constant (C_unit , []))
       ] , whole_expr
 
-  let annotation : T.type_value -> T.type_value -> (constraints * T.type_variable) =
+  let annotation : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
     fun e annot ->
       let e' = type_expression_to_type_value e in
       let annot' = type_expression_to_type_value annot in
@@ -314,20 +311,20 @@ module Wrap = struct
         C_equation (e' , P_variable whole_expr)
       ] , whole_expr
 
-  let matching : T.type_value list -> (constraints * T.type_variable) =
+  let matching : T.type_expression list -> (constraints * T.type_variable) =
     fun es ->
       let whole_expr = Core.fresh_type_variable () in
-      let type_values = (List.map type_expression_to_type_value es) in
-      let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values
+      let type_expressions = (List.map type_expression_to_type_value es) in
+      let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_expressions
       in cs, whole_expr
 
   let fresh_binder () =
     Core.fresh_type_variable ()
 
   let lambda
-    : T.type_value ->
-      T.type_value option ->
-      T.type_value option ->
+    : T.type_expression ->
+      T.type_expression option ->
+      T.type_expression option ->
       (constraints * T.type_variable) =
     fun fresh arg body ->
       let whole_expr = Core.fresh_type_variable () in
@@ -347,11 +344,11 @@ module Wrap = struct
         ] @ arg' @ body' , whole_expr
 
   (* This is pretty much a wrapper for an n-ary function. *)
-  let constant : O.type_value -> T.type_value list -> (constraints * T.type_variable) =
+  let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
     fun f args ->
       let whole_expr = Core.fresh_type_variable () in
       let args'      = List.map type_expression_to_type_value args in
-      let args_tuple = O.P_constant (C_tuple , args') in
+      let args_tuple = O.P_constant (C_record , args') in
       O.[
         C_equation (f , P_constant (C_arrow , [args_tuple ; P_variable whole_expr]))
       ] , whole_expr
@@ -441,8 +438,8 @@ and c_constructor_simpl = {
   tv_list : type_variable list;
 }
 (* copy-pasted from core.ml *)
-and c_const = (type_variable * type_value)
-and c_equation = (type_value * type_value)
+and c_const = (type_variable * type_expression)
+and c_equation = (type_expression * type_expression)
 and c_typeclass_simpl = {
   tc   : typeclass          ;
   args : type_variable list ;
@@ -742,97 +739,93 @@ let compare_simple_c_constant = function
   | C_arrow -> (function
       (* N/A -> 1 *)
       | C_arrow -> 0
-      | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+      | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_option -> (function
       | C_arrow -> 1
       | C_option -> 0
-      | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
-  | C_tuple -> (function
-      | C_arrow | C_option -> 1
-      | C_tuple -> 0
       |  C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_record -> (function
-      | C_arrow | C_option | C_tuple -> 1
+      | C_arrow | C_option  -> 1
       | C_record -> 0
       | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_variant -> (function
-      | C_arrow | C_option | C_tuple | C_record -> 1
+      | C_arrow | C_option  | C_record -> 1
       | C_variant -> 0
       | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_map -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant -> 1
+      | C_arrow | C_option  | C_record | C_variant -> 1
       | C_map -> 0
       | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_big_map -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1
+      | C_arrow | C_option  | C_record | C_variant | C_map -> 1
       | C_big_map -> 0
       | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_list -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1
+      | C_arrow | C_option  | C_record | C_variant | C_map | C_big_map -> 1
       | C_list -> 0
       | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_set -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1
       | C_set -> 0
       | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_unit -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
       | C_unit -> 0
       | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_bool -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
       | C_bool -> 0
       | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_string -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1
       | C_string -> 0
       | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_nat -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1
       | C_nat -> 0
       | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_mutez -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1
       | C_mutez -> 0
       | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_timestamp -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1
       | C_timestamp -> 0
       | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_int -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1
       | C_int -> 0
       | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_address -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
       | C_address -> 0
       | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_bytes -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
       | C_bytes -> 0
       | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_key_hash -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
       | C_key_hash -> 0
       | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_key -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
       | C_key -> 0
       | C_signature | C_operation | C_contract | C_chain_id -> -1)
   | C_signature -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
       | C_signature -> 0
       | C_operation | C_contract | C_chain_id -> -1)
   | C_operation -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
       | C_operation -> 0
       | C_contract | C_chain_id -> -1)
   | C_contract -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
       | C_contract -> 0
       | C_chain_id -> -1)
   | C_chain_id -> (function
-      | C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
+      | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
       | C_chain_id -> 0
       (* N/A -> -1 *)
     )
@@ -844,7 +837,6 @@ let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag ->
     let ct = match c_tag with
       | Core.C_arrow     -> "arrow"
       | Core.C_option    -> "option"
-      | Core.C_tuple     -> "tuple"
       | Core.C_record    -> failwith "record"
       | Core.C_variant   -> failwith "variant"
       | Core.C_map       -> "map"
@@ -910,16 +902,17 @@ let rec compare_list f = function
   | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
 let compare_type_variable a b =
   Var.compare a b
-let compare_label = function
-  | L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1)
-  | L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b)
-let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b
-and compare_type_value = function
+let compare_label (a:accessor) (b:accessor) = 
+  let Label a = a in
+  let Label b = b in
+  String.compare a b
+let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b
+and compare_type_expression = function
   | P_forall { binder=a1; constraints=a2; body=a3 } -> (function
       | P_forall { binder=b1; constraints=b2; body=b3 } ->
         compare_type_variable a1 b1 <? fun () ->
           compare_list compare_type_constraint a2 b2  <? fun () ->
-            compare_type_value a3 b3
+            compare_type_expression a3 b3
       | P_variable _ -> -1
       | P_constant _ -> -1
       | P_apply _ -> -1)
@@ -931,33 +924,33 @@ and compare_type_value = function
   | P_constant (a1, a2) -> (function
       | P_forall _ -> 1
       | P_variable _ -> 1
-      | P_constant (b1, b2) -> compare_simple_c_constant a1 b1 <? fun () -> compare_list compare_type_value a2 b2
+      | P_constant (b1, b2) -> compare_simple_c_constant a1 b1 <? fun () -> compare_list compare_type_expression a2 b2
       | P_apply _ -> -1)
   | P_apply (a1, a2) -> (function
       | P_forall _ -> 1
       | P_variable _ -> 1
       | P_constant _ -> 1
-      | P_apply (b1, b2) -> compare_type_value a1 b1 <? fun () -> compare_type_value a2 b2)
+      | P_apply (b1, b2) -> compare_type_expression a1 b1 <? fun () -> compare_type_expression a2 b2)
 and compare_type_constraint = function
   | C_equation (a1, a2) -> (function
-      | C_equation (b1, b2) -> compare_type_value a1 b1 <? fun () -> compare_type_value a2 b2
+      | C_equation (b1, b2) -> compare_type_expression a1 b1 <? fun () -> compare_type_expression a2 b2
       | C_typeclass _ -> -1
       | C_access_label _ -> -1)
   | C_typeclass (a1, a2) -> (function
       | C_equation _ -> 1
-      | C_typeclass (b1, b2) -> compare_list compare_type_value a1 b1 <? fun () -> compare_typeclass a2 b2
+      | C_typeclass (b1, b2) -> compare_list compare_type_expression a1 b1 <? fun () -> compare_typeclass a2 b2
       | C_access_label _ -> -1)
   | C_access_label (a1, a2, a3) -> (function
       | C_equation _ -> 1
       | C_typeclass _ -> 1
-      | C_access_label (b1, b2, b3) -> compare_type_value a1 b1 <? fun () -> compare_label a2 b2  <? fun () -> compare_type_variable a3 b3)
+      | C_access_label (b1, b2, b3) -> compare_type_expression a1 b1 <? fun () -> compare_label a2 b2  <? fun () -> compare_type_variable a3 b3)
 let compare_type_constraint_list = compare_list compare_type_constraint
 let compare_p_forall
     { binder = a1; constraints = a2; body = a3 }
     { binder = b1; constraints = b2; body = b3 } =
   compare_type_variable a1 b1 <? fun () ->
     compare_type_constraint_list a2 b2 <? fun () ->
-      compare_type_value a3 b3
+      compare_type_expression a3 b3
 let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
   compare_type_variable a1 b1 <? fun () ->
     compare_p_forall a2 b2
@@ -1110,7 +1103,7 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
  *   unification_vars : unionfind ;
  *
  *   (\* assigns a value to the representant in the unionfind *\)
- *   assignments : type_value TypeVariableMap.t ;
+ *   assignments : type_expression TypeVariableMap.t ;
  *
  *   (\* constraints related to a type variable *\)
  *   constraints : constraints TypeVariableMap.t ;
@@ -1151,7 +1144,7 @@ let initial_state : state = (* {
 let discard_state (_ : state) = ()
 
 (* let replace_var_in_state = fun (v : type_variable) (state : state) -> *)
-(*   let aux_tv : type_value -> _ = function *)
+(*   let aux_tv : type_expression -> _ = function *)
 (*     | P_forall    (w  , cs , tval) -> failwith "TODO" *)
 (*     | P_variable  (w)              -> *)
 (*       if w = v then *)

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

@@ -15,7 +15,7 @@ module Errors = struct
     let title = (thunk "unbound type variable") in
     let message () = "" in
     let data = [
-      ("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
+      ("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
       (* TODO: types don't have srclocs for now. *)
       (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
       ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
@@ -23,7 +23,7 @@ module Errors = struct
     error ~data title message ()
 
   let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
-    let name () = Format.asprintf "%a" Stage_common.PP.name n in
+    let name () = Format.asprintf "%a" I.PP.expression_variable n in
     let title = (thunk ("unbound variable "^(name ()))) in
     let message () = "" in
     let data = [
@@ -33,7 +33,7 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let match_empty_variant : type a . (a,unit) I.matching -> Location.t -> unit -> _ =
+  let match_empty_variant : I.matching_expr -> Location.t -> unit -> _ =
     fun matching loc () ->
       let title = (thunk "match with no cases") in
       let message () = "" in
@@ -43,7 +43,7 @@ module Errors = struct
       ] in
       error ~data title message ()
 
-  let match_missing_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
+  let match_missing_case : I.matching_expr -> Location.t -> unit -> _ =
     fun matching loc () ->
       let title = (thunk "missing case in match") in
       let message () = "" in
@@ -53,7 +53,7 @@ module Errors = struct
       ] in
       error ~data title message ()
 
-  let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
+  let match_redundant_case : I.matching_expr -> Location.t -> unit -> _ =
     fun matching loc () ->
       let title = (thunk "redundant case in match") in
       let message () = "" in
@@ -63,11 +63,11 @@ module Errors = struct
       ] in
       error ~data title message ()
 
-  let unbound_constructor (e:environment) (c:I.constructor) (loc:Location.t) () =
+  let unbound_constructor (e:environment) (c:I.constructor') (loc:Location.t) () =
     let title = (thunk "unbound constructor") in
     let message () = "" in
     let data = [
-      ("constructor" , fun () -> Format.asprintf "%a" Stage_common.PP.constructor c) ;
+      ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c) ;
       ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
@@ -103,27 +103,27 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_value option) () =
+  let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
     let title = (thunk "typing constant declaration") in
     let message () = "" in
     let data = [
-      ("constant" , fun () -> Format.asprintf "%a" Stage_common.PP.name name) ; (* Todo : remove Stage_common*)
+      ("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ; (* Todo : remove Stage_common*)
       ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
       ("expected" , fun () ->
           match expected with
             None -> "(no annotation for the expected type)"
-          | Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
+          | Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
     ] in
     error ~data title message ()
 
-  let match_error : type a . ?msg:string -> expected: (a, unit) I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
+  let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> Location.t -> unit -> _ =
     fun ?(msg = "") ~expected ~actual loc () ->
       let title = (thunk "typing match") in
       let message () = msg in
       let data = [
         ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
-        ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
+        ("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ;
         ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
       ] in
       error ~data title message ()
@@ -148,39 +148,17 @@ module Errors = struct
    *   ] in
    *   error ~data title message () *)
 
-  let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
+  let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
     let title = (thunk "type error") in
     let message () = msg in
     let data = [
-      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_value expected);
-      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
+      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
+      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
       ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
-    let title = (thunk "invalid tuple index") in
-    let message () = "" in
-    let data = [
-      ("index" , fun () -> Format.asprintf "%d" index) ;
-      ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
-    let title = (thunk "invalid record field") in
-    let message () = "" in
-    let data = [
-      ("field" , fun () -> Format.asprintf "%s" field) ;
-      ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
   let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
     let title = (thunk "not supported yet") in
     let message () = message in
@@ -216,7 +194,7 @@ let rec type_program (p:I.program) : O.program result =
 let rec type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function
   | Declaration_type (type_name , type_expression) ->
     let%bind tv = evaluate_type env type_expression in
-    let env' = Environment.add_type type_name tv env in
+    let env' = Environment.add_type (type_name) tv env in
     ok (env', state , None)
   | Declaration_constant (name , tv_opt , inline, expression) -> (
     (*
@@ -227,10 +205,10 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
         trace (constant_declaration_error name expression tv'_opt) @@
         type_expression env state expression in
       let env' = Environment.add_ez_ae name ae' env in
-      ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env'))))
+      ok (env', state' , Some (O.Declaration_constant (name, ae', inline, env') ))
     )
 
-and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.matching -> I.expression -> Location.t -> ((O.value, O.type_value) O.matching * Solver.state) result =
+and type_match : environment -> Solver.state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * Solver.state) result =
   fun e state t i ae loc -> match i with
     | Match_bool {match_true ; match_false} ->
       let%bind _ =
@@ -285,7 +263,7 @@ and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.mat
                          ~expression:ae
                          loc
                       ) @@
-                Ast_typed.assert_type_value_eq (variant , variant') >>? fun () ->
+                Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
                 ok (Some variant)
               ) in
           ok acc in
@@ -327,13 +305,13 @@ and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.mat
   Recursively search the type_expression and return a result containing the
   type_value at the leaves
 *)
-and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
+and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
   let return tv' = ok (make_t tv' (Some t)) in
-  match t.type_expression' with
-  | T_arrow (a, b) ->
-    let%bind a' = evaluate_type e a in
-    let%bind b' = evaluate_type e b in
-    return (T_arrow (a', b'))
+  match t.type_content with
+  | T_arrow {type1;type2} ->
+    let%bind type1 = evaluate_type e type1 in
+    let%bind type2 = evaluate_type e type2 in
+    return (T_arrow {type1;type2})
   | T_sum m ->
     let aux k v prev =
       let%bind prev' = prev in
@@ -353,7 +331,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
   | T_variable name ->
     let%bind tv =
       trace_option (unbound_type_variable e name)
-      @@ Environment.get_type_opt name e in
+      @@ Environment.get_type_opt (name) e in
     ok tv
   | T_constant cst ->
       return (T_constant cst)
@@ -383,13 +361,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
            let%bind arg' = evaluate_type e arg in
            let%bind ret' = evaluate_type e ret in
            ok @@ O.TC_arrow ( arg' , ret' )
-        | TC_tuple lst ->
-           let%bind lst' = bind_map_list (evaluate_type e) lst in
-           ok @@ O.TC_tuple lst'
         in
       return (T_operator (opt))
 
-and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ?tv_opt ae ->
+and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result = fun e state ?tv_opt ae ->
   let () = ignore tv_opt in     (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
   let open Solver in
   let module L = Logger.Stateful() in
@@ -410,7 +385,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
     ] in
     error ~data title content in
   trace main_error @@
-  match ae.expression with
+  match ae.expression_content with
 
   (* TODO: this file should take care only of the order in which program fragments
      are translated by Wrap.xyz
@@ -426,11 +401,12 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
    *     return expr''  state' constraints expr_type
    *   ) *)
   | E_variable name -> (
+      let name'= name in
       let%bind (tv' : Environment.element) =
         trace_option (unbound_variable e name ae.location)
-        @@ Environment.get_opt name e in
+        @@ Environment.get_opt name' e in
       let (constraints , expr_type) = Wrap.variable name tv'.type_value in
-      let expr' = e_variable name in
+      let expr' = e_variable name' in
       return expr' state constraints expr_type
     )
   | E_literal (Literal_bool b) -> (
@@ -475,6 +451,9 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
   | E_literal (Literal_unit) -> (
       return_wrapped (e_unit ()) state @@ Wrap.literal (t_unit ())
     )
+  | E_literal (Literal_void) -> (
+      failwith "TODO: missing implementation for literal void"
+    )
   | E_skip -> (
     (* E_skip just returns unit *)
     return_wrapped (e_unit ()) state @@ Wrap.literal (t_unit ())
@@ -485,44 +464,29 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
    *     | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
    *     | _ -> return (E_literal (Literal_string s)) (t_string ())
    *   ) *)
-  (* Tuple *)
-  | E_tuple lst  -> (
-      let aux state hd = type_expression e state hd >>? swap in
-      let%bind (state', lst') = bind_fold_map_list aux state lst in
-      let tv_lst = List.map get_type_annotation lst' in
-      return_wrapped (e_tuple lst') state' @@ Wrap.tuple tv_lst
-    )
-  | E_accessor (base , [Access_tuple index]) -> (
-      let%bind (base' , state') = type_expression e state base in
-      let wrapped = Wrap.access_int ~base:base'.type_annotation ~index in
-      return_wrapped (E_tuple_accessor (base' , index)) state' wrapped
-    )
-  | E_accessor (base , [Access_record property]) -> (
-      let%bind (base' , state') = type_expression e state base in
-      let wrapped = Wrap.access_string ~base:base'.type_annotation ~property in
-      return_wrapped (E_record_accessor (base' , Label property)) state' wrapped
-    )
-  | E_accessor (_base , []) | E_accessor (_base , _ :: _ :: _) -> (
-      failwith
-        "The simplifier should produce E_accessor with only a single path element, not a list of path elements."
+  | E_record_accessor {expr;label} -> (
+      let%bind (base' , state') = type_expression e state expr in
+      let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
+      return_wrapped (E_record_accessor {expr=base';label}) state' wrapped
     )
 
   (* Sum *)
-  | E_constructor (c, expr) ->
+  | E_constructor {constructor;element} ->
     let%bind (c_tv, sum_tv) =
       let error =
         let title () = "no such constructor" in
         let content () =
           Format.asprintf "%a in:\n%a\n"
-            Stage_common.PP.constructor c 
+            Stage_common.PP.constructor constructor
             O.Environment.PP.full_environment e
         in
         error title content in
       trace_option error @@
-      Environment.get_constructor c e in
-    let%bind (expr' , state') = type_expression e state expr in
-    let wrapped = Wrap.constructor expr'.type_annotation c_tv sum_tv in
-    return_wrapped (E_constructor (c , expr')) state' wrapped
+      Environment.get_constructor constructor e in
+    let%bind (expr' , state') = type_expression e state element in
+    let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
+    let wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
+    return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped
 
   (* Record *)
   | E_record m ->
@@ -530,25 +494,25 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
       let%bind (expr' , state') = type_expression e state expr in
       ok (I.LMap.add k expr' acc , state')
     in
-    let%bind (m' , state') = I.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
-    let wrapped = Wrap.record (I.LMap.map get_type_annotation m') in
+    let%bind (m' , state') = Stage_common.Helpers.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
+    let wrapped = Wrap.record (I.LMap.map get_type_expression m') in
     return_wrapped (E_record m') state' wrapped
-  | E_update {record; update=(k,expr)} ->
+  | E_record_update {record; path; update} ->
     let%bind (record, state) = type_expression e state record in
-    let%bind (expr,state) = type_expression e state expr in
-    let wrapped = get_type_annotation record in
+    let%bind (update,state) = type_expression e state update in
+    let wrapped = get_type_expression record in
     let%bind (wrapped,tv) = 
-      match wrapped.type_value' with 
+      match wrapped.type_content with 
       | T_record record -> (
-          let field_op = I.LMap.find_opt k record in
+          let field_op = I.LMap.find_opt path record in
           match field_op with
           | Some tv -> ok (record,tv)
-          | None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label k
+          | None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label path
       )
       | _ -> failwith "Update an expression which is not a record"
     in
-    let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr) in
-    return_wrapped (E_record_update (record, (k,expr))) state (Wrap.record wrapped)
+    let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
+    return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
   (* Data-structure *)
 
 (*
@@ -629,20 +593,20 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
   | E_list lst ->
     let%bind (state', lst') =
       bind_fold_map_list (fun state' elt -> type_expression e state' elt >>? swap) state lst in
-    let wrapped = Wrap.list (List.map (fun x -> O.(x.type_annotation)) lst') in
+    let wrapped = Wrap.list (List.map (fun x -> O.(x.type_expression)) lst') in
     return_wrapped (E_list lst') state' wrapped
   | E_set set ->
     let aux = fun state' elt -> type_expression e state' elt >>? swap in
     let%bind (state', set') =
       bind_fold_map_list aux state set in
-    let wrapped = Wrap.set (List.map (fun x -> O.(x.type_annotation)) set') in
+    let wrapped = Wrap.set (List.map (fun x -> O.(x.type_expression)) set') in
     return_wrapped (E_set set') state' wrapped
   | E_map map ->
     let aux' state' elt = type_expression e state' elt >>? swap in
     let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
     let%bind (state', map') =
       bind_fold_map_list aux state map in
-    let aux (x, y) = O.(x.type_annotation , y.type_annotation) in
+    let aux (x, y) = O.(x.type_expression , y.type_expression) in
     let wrapped = Wrap.map (List.map aux map') in
     return_wrapped (E_map map') state' wrapped
 
@@ -681,7 +645,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
     let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
     let%bind (state', big_map') =
       bind_fold_map_list aux state big_map in
-    let aux (x, y) = O.(x.type_annotation , y.type_annotation) in
+    let aux (x, y) = O.(x.type_expression , y.type_expression) in
     let wrapped = Wrap.big_map (List.map aux big_map') in
     return_wrapped (E_big_map big_map') state' wrapped
 
@@ -727,11 +691,11 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
    *   let%bind (name', tv) =
    *     type_constant name tv_lst tv_opt ae.location in
    *   return (E_constant (name' , lst')) tv *)
-  | E_application (f, arg) ->
-    let%bind (f' , state') = type_expression e state f in
-    let%bind (arg , state'') = type_expression e state' arg in
-    let wrapped = Wrap.application f'.type_annotation arg.type_annotation in
-    return_wrapped (E_application (f' , arg)) state'' wrapped
+  | E_application {expr1;expr2} ->
+    let%bind (f' , state') = type_expression e state expr1 in
+    let%bind (arg , state'') = type_expression e state' expr2 in
+    let wrapped = Wrap.application f'.type_expression arg.type_expression in
+    return_wrapped (E_application {expr1=f';expr2=arg}) state'' wrapped
 
   (* | E_look_up dsi ->
    *   let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in
@@ -742,7 +706,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
   | E_look_up dsi ->
     let aux' state' elt = type_expression e state' elt >>? swap in
     let%bind (state'' , (ds , ind)) = bind_fold_map_pair aux' state dsi in
-    let wrapped = Wrap.look_up ds.type_annotation ind.type_annotation in
+    let wrapped = Wrap.look_up ds.type_expression ind.type_expression in
     return_wrapped (E_look_up (ds , ind)) state'' wrapped
 
   (* Advanced *)
@@ -770,82 +734,52 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
    *       tv_opt in
    *     return (O.E_matching (ex', m')) tv
    *   ) *)
-  | E_sequence (a , b) ->
-    let%bind (a' , state') = type_expression e state a in
-    let%bind (b' , state'') = type_expression e state' b in
-    let wrapped = Wrap.sequence a'.type_annotation b'.type_annotation in
-    return_wrapped (O.E_sequence (a' , b')) state'' wrapped
-  | E_loop (expr , body) ->
-    let%bind (expr' , state') = type_expression e state expr in
+  | E_loop {condition; body} ->
+    let%bind (expr' , state') = type_expression e state condition in
     let%bind (body' , state'') = type_expression e state' body in
-    let wrapped = Wrap.loop expr'.type_annotation body'.type_annotation in
-    return_wrapped (O.E_loop (expr' , body')) state'' wrapped
-  | E_let_in {binder ; rhs ; result ; inline} ->
-    let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in
+    let wrapped = Wrap.loop expr'.type_expression body'.type_expression in
+    return_wrapped (O.E_loop {condition=expr';body=body'}) state'' wrapped
+  | E_let_in {let_binder ; rhs ; let_result; inline} ->
+    let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
     (* TODO: the binder annotation should just be an annotation node *)
     let%bind (rhs , state') = type_expression e state rhs in
-    let e' = Environment.add_ez_declaration (fst binder) rhs e in
-    let%bind (result , state'') = type_expression e' state' result in
+    let let_binder = fst let_binder in 
+    let e' = Environment.add_ez_declaration (let_binder) rhs e in
+    let%bind (let_result , state'') = type_expression e' state' let_result in
     let wrapped =
-      Wrap.let_in rhs.type_annotation rhs_tv_opt result.type_annotation in
-    return_wrapped (E_let_in {binder = fst binder; rhs; result; inline}) state'' wrapped
-  | E_assign (name , path , expr) ->
-    let%bind typed_name =
-      let%bind ele = Environment.get_trace name e in
-      ok @@ make_n_t name ele.type_value in
-    let%bind (assign_tv , path') =
-      let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path ->
-        match cur_path with
-        | Access_tuple index -> (
-            let%bind tpl = get_t_tuple prec_tv in
-            let%bind tv' =
-              trace_option (bad_tuple_index index ae prec_tv ae.location) @@
-              List.nth_opt tpl index in
-            ok (tv' , prec_path @ [O.Access_tuple index])
-          )
-        | Access_record property -> (
-            let%bind m = get_t_record prec_tv in
-            let%bind tv' =
-              trace_option (bad_record_access property ae prec_tv ae.location) @@
-              I.LMap.find_opt (Label property) m in
-            ok (tv' , prec_path @ [O.Access_record property])
-          )
-      in
-      bind_fold_list aux (typed_name.type_value , []) path in
-    let%bind (expr' , state') = type_expression e state expr in
-    let wrapped = Wrap.assign assign_tv expr'.type_annotation in
-    return_wrapped (O.E_assign (typed_name , path' , expr')) state' wrapped
-  | E_ascription (expr , te) ->
-    let%bind tv = evaluate_type e te in
-    let%bind (expr' , state') = type_expression e state expr in
-    let wrapped = Wrap.annotation expr'.type_annotation tv
+      Wrap.let_in rhs.type_expression rhs_tv_opt let_result.type_expression in
+    return_wrapped (E_let_in {let_binder; rhs; let_result; inline}) state'' wrapped
+  | E_ascription {anno_expr;type_annotation} ->
+    let%bind tv = evaluate_type e type_annotation in
+    let%bind (expr' , state') = type_expression e state anno_expr in
+    let wrapped = Wrap.annotation expr'.type_expression tv
     (* TODO: we're probably discarding too much by using expr'.expression.
        Previously: {expr' with type_annotation = the_explicit_type_annotation}
        but then this case is not like the others and doesn't call return_wrapped,
        which might do some necessary work *)
-    in return_wrapped expr'.expression state' wrapped
+    in return_wrapped expr'.expression_content state' wrapped
 
-  | E_matching (ex, m) -> (
-      let%bind (ex' , state') = type_expression e state ex in
-      let%bind (m' , state'') = type_match e state' ex'.type_annotation m ae ae.location in
+  | E_matching {matchee;cases} -> (
+      let%bind (ex' , state') = type_expression e state matchee in
+      let%bind (m' , state'') = type_match e state' ex'.type_expression cases ae ae.location in
       let tvs =
-        let aux (cur:(O.value, O.type_value) O.matching) =
+        let aux (cur:(O.expression, O.type_expression) O.matching_content) =
           match cur with
           | Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
           | Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
           | Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
           | Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
           | Match_variant (lst , _) -> List.map snd lst in
-        List.map get_type_annotation @@ aux m' in
+        List.map get_type_expression @@ aux m' in
       let%bind () = match tvs with
-          [] -> fail @@ match_empty_variant m ae.location
+          [] -> fail @@ match_empty_variant cases ae.location
         | _ -> ok () in
       (* constraints:
          all the items of tvs should be equal to the first one
          result = first item of tvs
       *)
       let wrapped = Wrap.matching tvs in
-      return_wrapped (O.E_matching (ex', m')) state'' wrapped
+      return_wrapped (O.E_matching {matchee=ex';cases=m'}) state'' wrapped
     )
 
   (* match m with *)
@@ -885,18 +819,19 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
       let%bind input_type' = bind_map_option (evaluate_type e) input_type in
       let%bind output_type' = bind_map_option (evaluate_type e) output_type in
 
-      let fresh : O.type_value = t_variable (Wrap.fresh_binder ()) () in
-      let e' = Environment.add_ez_binder (fst binder) fresh e in
+      let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in
+      let binder = fst binder in 
+      let e' = Environment.add_ez_binder (binder) fresh e in
 
       let%bind (result , state') = type_expression e' state result in
       let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in
       let wrapped = Wrap.lambda fresh input_type' output_type' in
       return_wrapped
-        (E_lambda {binder = fst binder; body=result}) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *)
+        (E_lambda {binder = binder; result}) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *)
         state' wrapped
     )
 
-  | E_constant (name, lst) ->
+  | E_constant {cons_name=name; arguments=lst} ->
     let () = ignore (name , lst) in
     let%bind t = Operators.Typer.Operators_types.constant_type name in
     let aux acc expr =
@@ -904,10 +839,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
       let%bind (expr, state') = type_expression e state expr in
       ok (expr::lst , state') in
     let%bind (lst , state') = bind_fold_list aux ([], state) lst in
-    let lst_annot = List.map (fun (x : O.value) -> x.type_annotation) lst in
+    let lst_annot = List.map (fun (x : O.expression) -> x.type_expression) lst in
     let wrapped = Wrap.constant t lst_annot in
     return_wrapped
-      (E_constant (name, lst))
+      (E_constant {cons_name=name;arguments=lst})
       state' wrapped
       (*
       let%bind lst' = bind_list @@ List.map (type_expression e) lst in
@@ -919,13 +854,13 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
 
 (* Advanced *)
 
-and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
+and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
   let%bind typer = Operators.Typer.constant_typers name in
   let%bind tv = typer lst tv_opt in
   ok(name, tv)
 
-let untype_type_value (t:O.type_value) : (I.type_expression) result =
-  match t.simplified with
+let untype_type_value (t:O.type_expression) : (I.type_expression) result =
+  match t.type_meta with
   | Some s -> ok s
   | _ -> fail @@ internal_assertion_failure "trying to untype generated type"
 (* let type_statement : environment -> I.declaration -> Solver.state -> (environment * O.declaration * Solver.state) result = fun env declaration state -> *)
@@ -978,7 +913,7 @@ let type_and_subst_xyz (env_state_node : environment * Solver.state * 'a) (apply
           (Solver.TypeVariableMap.find_opt root assignments) in
       let Solver.{ tv ; c_tag ; tv_list } = assignment in
       let () = ignore tv (* I think there is an issue where the tv is stored twice (as a key and in the element itself) *) in
-      let%bind (expr : O.type_value') = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.{ type_value' = T_variable s ; simplified = None }) tv_list)) in
+      let%bind (expr : O.type_content) = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.{ type_content = T_variable s ; type_meta = None }) tv_list)) in
       ok @@ expr
     in
     let p = apply_substs ~substs program in
@@ -992,14 +927,14 @@ let type_program (p : I.program) : (O.program * Solver.state) result =
   let empty_state = Solver.initial_state in
   type_and_subst_xyz (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
 
-let type_expression_returns_state : (environment * Solver.state * I.expression) -> (environment * Solver.state * O.annotated_expression) Trace.result =
+let type_expression_returns_state : (environment * Solver.state * I.expression) -> (environment * Solver.state * O.expression) Trace.result =
   fun (env, state, e) ->
   let%bind (e , state) = type_expression env state e in
   ok (env, state, e)
 
-let type_expression_subst (env : environment) (state : Solver.state) ?(tv_opt : O.type_value option) (e : I.expression) : (O.annotated_expression * Solver.state) result =
+let type_expression_subst (env : environment) (state : Solver.state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * Solver.state) result =
   let () = ignore tv_opt in     (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
-  type_and_subst_xyz (env , state , e) Typesystem.Misc.Substitution.Pattern.s_annotated_expression type_expression_returns_state
+  type_and_subst_xyz (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
 
  (*
 TODO: Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity
@@ -1025,22 +960,22 @@ let type_program' : I.program -> O.program result = fun p ->
 (*
   Tranform a Ast_typed type_expression into an ast_simplified type_expression
 *)
-let rec untype_type_expression (t:O.type_value) : (I.type_expression) result =
+let rec untype_type_expression (t:O.type_expression) : (I.type_expression) result =
   (* TODO: or should we use t.simplified if present? *)
-  let%bind t = match t.type_value' with
+  let%bind t = match t.type_content with
   | O.T_sum x ->
-    let%bind x' = I.bind_map_cmap untype_type_expression x in
+    let%bind x' = Stage_common.Helpers.bind_map_cmap untype_type_expression x in
     ok @@ I.T_sum x'
   | O.T_record x ->
-    let%bind x' = I.bind_map_lmap untype_type_expression x in
+    let%bind x' = Stage_common.Helpers.bind_map_lmap untype_type_expression x in
     ok @@ I.T_record x'
   | O.T_constant (tag) ->
     ok @@ I.T_constant (tag)
-  | O.T_variable (name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *)
-  | O.T_arrow (a , b) ->
-    let%bind a' = untype_type_expression a in
-    let%bind b' = untype_type_expression b in
-    ok @@ I.T_arrow (a' , b')
+  | O.T_variable (name) -> ok @@ I.T_variable (name) (* TODO: is this the right conversion? *)
+  | O.T_arrow {type1;type2} ->
+    let%bind type1 = untype_type_expression type1 in
+    let%bind type2 = untype_type_expression type2 in
+    ok @@ I.T_arrow {type1;type2}
   | O.T_operator (type_name) ->
       let%bind type_name = match type_name with
       | O.TC_option t -> 
@@ -1060,16 +995,13 @@ let rec untype_type_expression (t:O.type_value) : (I.type_expression) result =
          let%bind k = untype_type_expression k in
          let%bind v = untype_type_expression v in
          ok @@ I.TC_big_map (k,v)
-      | O.TC_contract c->
-         let%bind c = untype_type_expression c in
-         ok @@ I.TC_contract c
       | O.TC_arrow ( arg , ret ) ->
          let%bind arg' = untype_type_expression arg in
          let%bind ret' = untype_type_expression ret in
          ok @@ I.TC_arrow ( arg' , ret' )
-      | O.TC_tuple lst ->
-         let%bind lst' = bind_map_list untype_type_expression lst in
-         ok @@ I.TC_tuple lst'
+      | O.TC_contract c->
+         let%bind c = untype_type_expression c in
+         ok @@ I.TC_contract c
       in
       ok @@ I.T_operator (type_name)
     in
@@ -1087,6 +1019,7 @@ let untype_literal (l:O.literal) : I.literal result =
   let open I in
   match l with
   | Literal_unit -> ok Literal_unit
+  | Literal_void -> ok Literal_void
   | Literal_bool b -> ok (Literal_bool b)
   | Literal_nat n -> ok (Literal_nat n)
   | Literal_timestamp n -> ok (Literal_timestamp n)
@@ -1104,51 +1037,46 @@ let untype_literal (l:O.literal) : I.literal result =
 (*
   Tranform a Ast_typed expression into an ast_simplified matching
 *)
-let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
+let rec untype_expression (e:O.expression) : (I.expression) result =
   let open I in
   let return e = ok e in
-  match e.expression with
+  match e.expression_content with
   | E_literal l ->
     let%bind l = untype_literal l in
     return (e_literal l)
-  | E_constant (const, lst) ->
-    let%bind lst' = bind_map_list untype_expression lst in
-    return (e_constant const lst')
+  | E_constant {cons_name;arguments} ->
+      let%bind lst' = bind_map_list untype_expression arguments in
+      return (e_constant cons_name lst')
   | E_variable (n) ->
-    return (e_variable n)
-  | E_application (f, arg) ->
-    let%bind f' = untype_expression f in
-    let%bind arg' = untype_expression arg in
+    return (e_variable (n))
+  | E_application {expr1;expr2} ->
+      let%bind f' = untype_expression expr1 in
+      let%bind arg' = untype_expression expr2 in
       return (e_application f' arg')
-  | E_lambda {binder; body} -> (
-      let%bind io = get_t_function e.type_annotation in
+  | E_lambda {binder; result} -> (
+      let%bind io = get_t_function e.type_expression in
       let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
-      let%bind result = untype_expression body in
-      return (e_lambda binder (Some input_type) (Some output_type) result)
+      let%bind result = untype_expression result in
+      return (e_lambda (binder) (Some input_type) (Some output_type) result)
     )
-  | E_tuple lst ->
-    let%bind lst' = bind_list
-      @@ List.map untype_expression lst in
-    return (e_tuple lst')
-  | E_tuple_accessor (tpl, ind)  ->
-    let%bind tpl' = untype_expression tpl in
-    return (e_accessor tpl' [Access_tuple ind])
-  | E_constructor (Constructor c, p) ->
-    let%bind p' = untype_expression p in
-    return (e_constructor c p')
+  | E_constructor {constructor; element} ->
+      let%bind p' = untype_expression element in
+      let Constructor n = constructor in
+      return (e_constructor n p')
   | E_record r ->
     let aux ( Label k ,v) = (k, v) in
     let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
     let%bind r' = bind_smap
       @@ Map.String.map untype_expression r in
     return (e_record r')
-  | E_record_accessor (r, Label s) ->
-    let%bind r' = untype_expression r in
-    return (e_accessor r' [Access_record s])
-  | E_record_update (r, (l,e)) ->
-    let%bind r' = untype_expression r in
-    let%bind e = untype_expression e in 
-    let Label l = l in
+  | E_record_accessor {expr; label} ->
+    let%bind r' = untype_expression expr in
+    let Label s = label in
+    return (e_accessor r' s)
+  | E_record_update {record; path; update} ->
+    let%bind r' = untype_expression record in
+    let%bind e = untype_expression update in 
+    let Label l = path in
     return (e_update r' l e)
   | E_map m ->
     let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
@@ -1165,26 +1093,24 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
   | E_look_up dsi ->
     let%bind (a , b) = bind_map_pair untype_expression dsi in
     return (e_look_up a b)
-  | E_matching (ae, m) ->
-    let%bind ae' = untype_expression ae in
-    let%bind m' = untype_matching untype_expression m in
+  | E_matching {matchee;cases} ->
+    let%bind ae' = untype_expression matchee in
+    let%bind m' = untype_matching untype_expression cases in
     return (e_matching ae' m')
   (* | E_failwith ae ->
    *   let%bind ae' = untype_expression ae in
    *   return (e_failwith ae') *)
-  | E_sequence _
-  | E_loop _
-  | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
-  | E_let_in {binder; rhs; result; inline} ->
-    let%bind tv = untype_type_value rhs.type_annotation in
+  | E_loop _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
+  | E_let_in {let_binder; rhs;let_result; inline} ->
+    let%bind tv = untype_type_value rhs.type_expression in
     let%bind rhs = untype_expression rhs in
-    let%bind result = untype_expression result in
-    return (e_let_in (binder , (Some tv)) inline rhs result)
+    let%bind result = untype_expression let_result in
+    return (e_let_in (let_binder , (Some tv)) false inline rhs result)
 
 (*
   Tranform a Ast_typed matching into an ast_simplified matching
 *)
-and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
+and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
   let open I in
   match m with
   | Match_bool {match_true ; match_false} ->

src/passes/4-typer-new/typer.mli

@@ -42,16 +42,16 @@ val type_program : I.program -> (O.program * Solver.state) result
 val type_program' : I.program -> (O.program) result (* TODO: merge with type_program *)
 val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result
 (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
-val evaluate_type : environment -> I.type_expression -> O.type_value result
-val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
-val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
-val type_constant : I.constant -> O.type_value list -> O.type_value option -> (O.constant * O.type_value) result
+val evaluate_type : environment -> I.type_expression -> O.type_expression result
+val type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
+val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
+val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
 (*
 val untype_type_value : O.type_value -> (I.type_expression) result
 val untype_literal : O.literal -> I.literal result
 *)
-val untype_type_expression : O.type_value -> I.type_expression result
-val untype_expression : O.annotated_expression -> I.expression result
+val untype_type_expression : O.type_expression -> I.type_expression result
+val untype_expression : O.expression -> I.expression result
 (*
 val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
 *)

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

@@ -21,7 +21,7 @@ module Errors = struct
     let title = (thunk "unbound type variable") in
     let message () = "" in
     let data = [
-      ("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
+      ("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
       (* TODO: types don't have srclocs for now. *)
       (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
       ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
@@ -30,7 +30,7 @@ module Errors = struct
     error ~data title message ()
 
   let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
-    let name () = Format.asprintf "%a" Stage_common.PP.name n in
+    let name () = Format.asprintf "%a" I.PP.expression_variable n in
     let title = (thunk ("unbound variable "^(name ()))) in
     let message () = "" in
     let data = [
@@ -40,7 +40,7 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let match_empty_variant : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
+  let match_empty_variant : I.matching_expr -> Location.t -> unit -> _ =
     fun matching loc () ->
       let title = (thunk "match with no cases") in
       let message () = "" in
@@ -50,7 +50,7 @@ module Errors = struct
       ] in
       error ~data title message ()
 
-  let match_missing_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
+  let match_missing_case : I.matching_expr -> Location.t -> unit -> _ =
     fun matching loc () ->
     let title = (thunk "missing case in match") in
     let message () = "" in
@@ -60,7 +60,7 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
+  let match_redundant_case : I.matching_expr -> Location.t -> unit -> _ =
     fun matching loc () ->
     let title = (thunk "redundant case in match") in
     let message () = "" in
@@ -70,11 +70,11 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let unbound_constructor (e:environment) (c:I.constructor) (loc:Location.t) () =
+  let unbound_constructor (e:environment) (c:I.constructor') (loc:Location.t) () =
     let title = (thunk "unbound constructor") in
     let message () = "" in
     let data = [
-      ("constructor" , fun () -> Format.asprintf "%a" Stage_common.PP.constructor c);
+      ("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
       ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
@@ -91,6 +91,7 @@ module Errors = struct
     ] in
     error ~data title message ()
 
+
   let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
     let title () = "matching tuple of different size" in
     let message () = "" in
@@ -110,27 +111,27 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_value option) () =
+  let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
     let title = (thunk "typing constant declaration") in
     let message () = "" in
     let data = [
-      ("constant" , fun () -> Format.asprintf "%a" Stage_common.PP.name name) ;
+      ("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ;
       ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
       ("expected" , fun () ->
           match expected with
             None -> "(no annotation for the expected type)"
-          | Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
+          | Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
     ] in
     error ~data title message ()
 
-  let match_error : type a . ?msg:string -> expected: (a, unit) I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
+  let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> Location.t -> unit -> _ =
     fun ?(msg = "") ~expected ~actual loc () ->
     let title = (thunk "typing match") in
     let message () = msg in
     let data = [
       ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
-      ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
+      ("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
@@ -144,46 +145,35 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
+  let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
     let title = (thunk "type error") in
     let message () = msg in
     let data = [
       ("expected"   , fun () -> Format.asprintf "%s" expected);
-      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
+      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
       ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
+  let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
     let title = (thunk "type error") in
     let message () = msg in
     let data = [
-      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_value expected);
-      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_value actual);
+      ("expected"   , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
+      ("actual"     , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
       ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
 
-  let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
-    let title = (thunk "invalid tuple index") in
-    let message () = "" in
-    let data = [
-      ("index" , fun () -> Format.asprintf "%d" index) ;
-      ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
-      ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
-    ] in
-    error ~data title message ()
-
-  let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
+  let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_expression) (loc:Location.t) () =
     let title = (thunk "invalid record field") in
     let message () = "" in
     let data = [
-      ("field" , fun () -> Format.asprintf "%a" Stage_common.PP.label field) ;
+      ("field" , fun () -> Format.asprintf "%a" I.PP.label field) ;
       ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
-      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
+      ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_expression t) ;
       ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
     ] in
     error ~data title message ()
@@ -216,7 +206,7 @@ let rec type_program (p:I.program) : (O.program * Solver.state) result =
 and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) : I.declaration -> (environment * Solver.state * O.declaration option) result = function
   | Declaration_type (type_name , type_expression) ->
       let%bind tv = evaluate_type env type_expression in
-      let env' = Environment.add_type type_name tv env in
+      let env' = Environment.add_type (type_name) tv env in
       ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
   | Declaration_constant (name , tv_opt , inline, expression) -> (
       let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
@@ -224,10 +214,10 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) :
         trace (constant_declaration_error name expression tv'_opt) @@
         type_expression' ?tv_opt:tv'_opt env expression in
       let env' = Environment.add_ez_ae name ae' env in
-      ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env'))))
+      ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant (name,ae', inline, env')))
     )
 
-and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> (i, unit) I.matching -> I.expression -> Location.t -> (o, O.type_value) O.matching result =
+and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
   fun f e t i ae loc -> match i with
     | Match_bool {match_true ; match_false} ->
       let%bind _ =
@@ -282,7 +272,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
                          ~expression:ae
                          loc
                       ) @@
-                Ast_typed.assert_type_value_eq (variant , variant') >>? fun () ->
+                Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
                 ok (Some variant)
               ) in
           ok acc in
@@ -320,13 +310,13 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
         bind_map_list aux lst in
       ok (O.Match_variant (lst' , variant))
 
-and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
+and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
   let return tv' = ok (make_t tv' (Some t)) in
-  match t.type_expression' with
-  | T_arrow (a, b) ->
-      let%bind a' = evaluate_type e a in
-      let%bind b' = evaluate_type e b in
-      return (T_arrow (a', b'))
+  match t.type_content with
+  | T_arrow {type1;type2} ->
+      let%bind type1 = evaluate_type e type1 in
+      let%bind type2 = evaluate_type e type2 in
+      return (T_arrow {type1;type2})
   | T_sum m ->
       let aux k v prev =
         let%bind prev' = prev in
@@ -346,7 +336,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
   | T_variable name ->
       let%bind tv =
         trace_option (unbound_type_variable e name)
-        @@ Environment.get_type_opt name e in
+        @@ Environment.get_type_opt (name) e in
       ok tv
   | T_constant cst ->
       return (T_constant cst)
@@ -369,30 +359,27 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
             let%bind k = evaluate_type e k in 
             let%bind v = evaluate_type e v in 
             ok @@ O.TC_big_map (k,v) 
-        | TC_contract c ->
-            let%bind c = evaluate_type e c in
-            ok @@ I.TC_contract c
         | TC_arrow ( arg , ret ) ->
             let%bind arg' = evaluate_type e arg in
             let%bind ret' = evaluate_type e ret in
-            ok @@ I.TC_arrow ( arg' , ret' )
-        | TC_tuple lst ->
-            let%bind lst' = bind_map_list (evaluate_type e) lst in
-            ok @@ I.TC_tuple lst'
+            ok @@ O.TC_arrow ( arg' , ret' )
+        | TC_contract c ->
+            let%bind c = evaluate_type e c in
+            ok @@ O.TC_contract c
         in
       return (T_operator (opt))
 
-and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
+and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
   = fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
     let%bind res = type_expression' e ?tv_opt ae in
     ok (res, (Solver.placeholder_for_state_of_new_typer ()))
-and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result = fun e ?tv_opt ae ->
+and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae ->
   let module L = Logger.Stateful() in
   let return expr tv =
     let%bind () =
       match tv_opt with
       | None -> ok ()
-      | Some tv' -> O.assert_type_value_eq (tv' , tv) in
+      | Some tv' -> O.assert_type_expression_eq (tv' , tv) in
     let location = ae.location in
     ok @@ make_a_e ~location expr tv e in
   let main_error =
@@ -405,7 +392,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
     ] in
     error ~data title content in
   trace main_error @@
-  match ae.expression with
+  match ae.expression_content with
   (* Basic *)
   | E_variable name ->
       let%bind tv' =
@@ -416,6 +403,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
       return (E_literal (Literal_bool b)) (t_bool ())
   | E_literal Literal_unit | E_skip ->
       return (E_literal (Literal_unit)) (t_unit ())
+  | E_literal Literal_void -> return (E_literal (Literal_void)) (t_unit ()) (* TODO : IS this really a t_unit ?*)
   | E_literal (Literal_string s) ->
       return (E_literal (Literal_string s)) (t_string ())
   | E_literal (Literal_key s) ->
@@ -440,82 +428,66 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
       return (e_address s) (t_address ())
   | E_literal (Literal_operation op) ->
       return (e_operation op) (t_operation ())
-  (* Tuple *)
-  | E_tuple lst ->
-      let%bind lst' = bind_list @@ List.map (type_expression' e) lst in
-      let tv_lst = List.map get_type_annotation lst' in
-      return (E_tuple lst') (t_tuple tv_lst ())
-  | E_accessor (ae', path) ->
-      let%bind e' = type_expression' e ae' in
-      let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result =
-        match a with
-        | Access_tuple index -> (
-            let%bind tpl_tv = get_t_tuple prev.type_annotation in
+  | E_record_accessor {expr;label} ->
+      let%bind e' = type_expression' e expr in
+      let aux (prev:O.expression) (a:I.label) : O.expression result =
+            let property = a in
+            let%bind r_tv = get_t_record prev.type_expression in
             let%bind tv =
-              generic_try (bad_tuple_index index ae' prev.type_annotation ae.location)
-              @@ (fun () -> List.nth tpl_tv index) in
-            let location = ae.location in
-            ok @@ make_a_e ~location (E_tuple_accessor(prev , index)) tv e
-          )
-        | Access_record property -> (
-            let property = I.Label property in
-            let%bind r_tv = get_t_record prev.type_annotation in
-            let%bind tv =
-              generic_try (bad_record_access property ae' prev.type_annotation ae.location)
+              generic_try (bad_record_access property ae prev.type_expression ae.location)
               @@ (fun () -> I.LMap.find property r_tv) in
             let location = ae.location in
-            ok @@ make_a_e ~location (E_record_accessor (prev , property)) tv e
-          )
+            ok @@ make_a_e ~location (E_record_accessor {expr=prev; label=property}) tv e
       in
       let%bind ae =
-      trace (simple_info "accessing") @@
-      bind_fold_list aux e' path in
+      trace (simple_info "accessing") @@ aux e' label in
       (* check type annotation of the final accessed element *)
       let%bind () =
         match tv_opt with
         | None -> ok ()
-        | Some tv' -> O.assert_type_value_eq (tv' , ae.type_annotation) in
+        | Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in
       ok(ae)
   (* Sum *)
-  | E_constructor (c, expr) ->
+  | E_constructor {constructor; element} ->
       let%bind (c_tv, sum_tv) =
         let error =
           let title () = "no such constructor" in
           let content () =
             Format.asprintf "%a in:\n%a\n"
-              Stage_common.PP.constructor c 
+              Stage_common.PP.constructor constructor 
               O.Environment.PP.full_environment e
           in
           error title content in
         trace_option error @@
-        Environment.get_constructor c e in
-      let%bind expr' = type_expression' e expr in
-      let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in
-      return (E_constructor (c , expr')) sum_tv
+        Environment.get_constructor constructor e in
+      let%bind expr' = type_expression' e element in
+      let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
+      return (E_constructor {constructor; element=expr'}) sum_tv
   (* Record *)
   | E_record m ->
       let aux prev k expr =
         let%bind expr' = type_expression' e expr in
         ok (I.LMap.add k expr' prev)
       in
-      let%bind m' = I.bind_fold_lmap aux (ok I.LMap.empty) m in
-      return (E_record m') (t_record (I.LMap.map get_type_annotation m') ())
-  | E_update {record; update =(l,expr)} ->
+      let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok I.LMap.empty) m in
+      return (E_record m') (t_record (I.LMap.map get_type_expression m') ())
+  | E_record_update {record; path; update} ->
+
     let%bind record = type_expression' e record in
-    let%bind expr' = type_expression' e expr in
-    let wrapped = get_type_annotation record in
+    let%bind update = type_expression' e update in
+    let wrapped = get_type_expression record in
     let%bind tv = 
-      match wrapped.type_value' with 
+      match wrapped.type_content with 
       | T_record record -> (
-          let field_op = I.LMap.find_opt l record in
+          let field_op = I.LMap.find_opt path record in
           match field_op with
           | Some tv -> ok (tv)
-          | None -> failwith @@ Format.asprintf "field %a is not part of record %a" Stage_common.PP.label l O.PP.type_value wrapped
+          | None -> failwith @@ Format.asprintf "field %a is not part of record %a" Stage_common.PP.label path O.PP.type_expression wrapped
       )
       | _ -> failwith "Update an expression which is not a record"
     in
-    let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr') in
-    return (E_record_update (record, (l,expr'))) wrapped
+    let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
+    return (E_record_update {record; path; update}) wrapped
   (* Data-structure *)
   | E_list lst ->
       let%bind lst' = bind_map_list (type_expression' e) lst in
@@ -524,7 +496,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
           match opt with
           | None -> ok (Some c)
           | Some c' ->
-              let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
+              let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
               ok (Some c') in
         let%bind init = match tv_opt with
           | None -> ok None
@@ -533,7 +505,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
               ok (Some ty') in
         let%bind ty =
           let%bind opt = bind_fold_list aux init
-          @@ List.map get_type_annotation lst' in
+          @@ List.map get_type_expression lst' in
           trace_option (needs_annotation ae "empty list") opt in
         ok (t_list ty ())
       in
@@ -545,7 +517,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
           match opt with
           | None -> ok (Some c)
           | Some c' ->
-              let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
+              let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
               ok (Some c') in
         let%bind init = match tv_opt with
           | None -> ok None
@@ -554,7 +526,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
               ok (Some ty') in
         let%bind ty =
           let%bind opt = bind_fold_list aux init
-          @@ List.map get_type_annotation lst' in
+          @@ List.map get_type_expression lst' in
           trace_option (needs_annotation ae "empty set") opt in
         ok (t_set ty ())
       in
@@ -566,12 +538,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
           match opt with
           | None -> ok (Some c)
           | Some c' ->
-              let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
+              let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
               ok (Some c') in
         let%bind key_type =
           let%bind sub =
             bind_fold_list aux None
-            @@ List.map get_type_annotation
+            @@ List.map get_type_expression
             @@ List.map fst lst' in
           let%bind annot = bind_map_option get_t_map_key tv_opt in
           trace (simple_info "empty map expression without a type annotation") @@
@@ -580,7 +552,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
         let%bind value_type =
           let%bind sub =
             bind_fold_list aux None
-            @@ List.map get_type_annotation
+            @@ List.map get_type_expression
             @@ List.map snd lst' in
           let%bind annot = bind_map_option get_t_map_value tv_opt in
           trace (simple_info "empty map expression without a type annotation") @@
@@ -596,12 +568,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
           match opt with
           | None -> ok (Some c)
           | Some c' ->
-              let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
+              let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
               ok (Some c') in
         let%bind key_type =
           let%bind sub =
             bind_fold_list aux None
-            @@ List.map get_type_annotation
+            @@ List.map get_type_expression
             @@ List.map fst lst' in
           let%bind annot = bind_map_option get_t_big_map_key tv_opt in
           trace (simple_info "empty map expression without a type annotation") @@
@@ -610,7 +582,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
         let%bind value_type =
           let%bind sub =
             bind_fold_list aux None
-            @@ List.map get_type_annotation
+            @@ List.map get_type_expression
             @@ List.map snd lst' in
           let%bind annot = bind_map_option get_t_big_map_value tv_opt in
           trace (simple_info "empty map expression without a type annotation") @@
@@ -632,11 +604,11 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
           match input_type with
           | Some ty -> ok ty
           | None -> (
-              match result.expression with
+              match result.expression_content with
               | I.E_let_in li -> (
-                  match li.rhs.expression with
+                  match li.rhs.expression_content with
                   | I.E_variable name when name = (fst binder) -> (
-                      match snd li.binder with
+                      match snd li.let_binder with
                       | Some ty -> ok ty
                       | None -> default_action li.rhs ()
                     )
@@ -649,119 +621,133 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
       let%bind output_type =
         bind_map_option (evaluate_type e) output_type
       in
-      let e' = Environment.add_ez_binder (fst binder) input_type e in
+      let binder = fst binder in
+      let e' = Environment.add_ez_binder binder input_type e in
       let%bind body = type_expression' ?tv_opt:output_type e' result in
-      let output_type = body.type_annotation in
-      return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ())
+      let output_type = body.type_expression in
+      return (E_lambda {binder; result=body}) (t_function input_type output_type ())
     )
-  | E_constant ( ( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ,
-                  [
-                    ( { expression = (I.E_lambda { binder = (lname, None) ;
+  | E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ;
+                arguments=[
+                    ( { expression_content = (I.E_lambda { binder = (lname, None) ;
                                                    input_type = None ; 
                                                    output_type = None ; 
                                                    result }) ;
                         location = _ }) as _lambda ;
                     collect ; 
                     init_record ;
-                  ] ) ->
+                  ]} ->
       (* this special case is here force annotation of the untyped lambda
          generated by pascaligo's for_collect loop *)
       let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in
-      let tv_col = get_type_annotation v_col   in (* this is the type of the collection  *) 
-      let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*)
-      let%bind input_type = match tv_col.type_value' with
-        | O.T_operator ( TC_list t | TC_set t) -> ok @@ t_tuple (tv_out::[t]) ()
-        | O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ t_tuple (tv_out::[(t_tuple [k;v] ())]) () 
+      let tv_col = get_type_expression v_col   in (* this is the type of the collection  *) 
+      let tv_out = get_type_expression v_initr in (* this is the output type of the lambda*)
+      let%bind input_type = match tv_col.type_content with
+        | O.T_operator ( TC_list t | TC_set t) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",t)])
+        | O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])])
         | _ ->
           let wtype = Format.asprintf
-            "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in 
+            "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in 
           fail @@ simple_error wtype in 
+      let lname = lname in
       let e' = Environment.add_ez_binder lname input_type e in
       let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
-      let output_type = body.type_annotation in
-      let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in
+      let output_type = body.type_expression in
+      let lambda' = make_a_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
       let lst' = [lambda'; v_col; v_initr] in
-      let tv_lst = List.map get_type_annotation lst' in
+      let tv_lst = List.map get_type_expression lst' in
       let%bind (opname', tv) =
         type_constant opname tv_lst tv_opt in
-      return (E_constant (opname' , lst')) tv
-  | E_constant (name, lst) ->
-      let%bind lst' = bind_list @@ List.map (type_expression' e) lst in
-      let tv_lst = List.map get_type_annotation lst' in
+      return (E_constant {cons_name=opname';arguments=lst'}) tv
+  | E_constant {cons_name=C_FOLD_WHILE as opname;
+                arguments = [
+                    ( { expression_content = (I.E_lambda { binder = (lname, None) ;
+                                                   input_type = None ; 
+                                                   output_type = None ; 
+                                                   result }) ;
+                        location = _ }) as _lambda ;
+                    init_record ;
+                ]} -> 
+      Format.printf "typing foldwhile \n %!";
+      let%bind v_initr = type_expression' e init_record in
+      let tv_out = get_type_expression v_initr in
+      let input_type  = tv_out in
+      let e' = Environment.add_ez_binder lname input_type e in
+      Format.printf "typing foldwhile %a\n %a\n %!" Ast_typed.PP.type_expression tv_out I.PP.expression result;
+      let%bind body = type_expression' e' result in
+      Format.printf "typing foldwhile %a\n %!" O.PP.expression body;
+      let output_type = body.type_expression in
+      let lambda' = make_a_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
+      let lst' = [lambda';v_initr] in
+      let tv_lst = List.map get_type_expression lst' in
+      Format.printf "Typing constant : %a \n%!" (Ast_typed.PP.list_sep_d Ast_typed.PP.type_expression) tv_lst;
+      let%bind (opname',tv) = type_constant opname tv_lst tv_opt in
+      Format.printf "Typed constant : %a \n%!" O.PP.type_expression tv;
+      return (E_constant {cons_name=opname';arguments=lst'}) tv
+  | E_constant {cons_name;arguments} ->
+      let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in
+      let tv_lst = List.map get_type_expression lst' in
       let%bind (name', tv) =
-        type_constant name tv_lst tv_opt in
-      return (E_constant (name' , lst')) tv
-  | E_application (f, arg) ->
-      let%bind f' = type_expression' e f in
-      let%bind arg = type_expression' e arg in
-      let%bind tv = match f'.type_annotation.type_value' with
-        | T_arrow (param, result) ->
-            let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in
-            ok result
+        type_constant cons_name tv_lst tv_opt in
+      return (E_constant {cons_name=name';arguments=lst'}) tv
+  | E_application {expr1;expr2} ->
+      let%bind expr1' = type_expression' e expr1 in
+      let%bind expr2 = type_expression' e expr2 in
+      let%bind tv = match expr1'.type_expression.type_content with
+        | T_arrow {type1;type2} ->
+            let%bind _ = O.assert_type_expression_eq (type1, expr2.type_expression) in
+            ok type2
         | _ ->
           fail @@ type_error_approximate
             ~expected:"should be a function type"
-            ~expression:f
-            ~actual:f'.type_annotation
-            f'.location
+            ~expression:expr1
+            ~actual:expr1'.type_expression
+            expr1'.location
       in
-      return (E_application (f' , arg)) tv
+      return (E_application {expr1=expr1';expr2}) tv
   | E_look_up dsi ->
       let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in
-      let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in
-      let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in
+      let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in
+      let%bind _ = O.assert_type_expression_eq (ind.type_expression, src) in
       return (E_look_up (ds , ind)) (t_option dst ())
   (* Advanced *)
-  | E_matching (ex, m) -> (
-      let%bind ex' = type_expression' e ex in
-      let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_annotation m ae ae.location in
+  | E_matching {matchee;cases} -> (
+      let%bind ex' = type_expression' e matchee in
+      let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_expression cases ae ae.location in
       let tvs =
-        let aux (cur:(O.value, O.type_value) O.matching) =
+        let aux (cur:O.matching_expr) =
           match cur with
           | Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
           | Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
           | Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
           | Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
           | Match_variant (lst , _) -> List.map snd lst in
-        List.map get_type_annotation @@ aux m' in
+        List.map get_type_expression @@ aux m' in
       let aux prec cur =
         let%bind () =
           match prec with
           | None -> ok ()
-          | Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in
+          | Some cur' -> Ast_typed.assert_type_expression_eq (cur , cur') in
         ok (Some cur) in
       let%bind tv_opt = bind_fold_list aux None tvs in
       let%bind tv =
-        trace_option (match_empty_variant m ae.location) @@
+        trace_option (match_empty_variant cases ae.location) @@
         tv_opt in
-      return (O.E_matching (ex', m')) tv
+      return (O.E_matching {matchee=ex'; cases=m'}) tv
     )
-  | E_sequence (a , b) ->
-    let%bind a' = type_expression' e a in
-    let%bind b' = type_expression' e b in
-    let a'_type_annot = get_type_annotation a' in
-    let%bind () =
-      trace_strong (type_error
-                      ~msg:"first part of the sequence should be of unit type"
-                      ~expected:(O.t_unit ())
-                      ~actual:a'_type_annot
-                      ~expression:a
-                      a'.location) @@
-      Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in
-    return (O.E_sequence (a' , b')) (get_type_annotation b')
-  | E_loop (expr , body) ->
-    let%bind expr' = type_expression' e expr in
+  | E_loop {condition; body} ->
+    let%bind expr' = type_expression' e condition in
     let%bind body' = type_expression' e body in
-    let t_expr' = get_type_annotation expr' in
+    let t_expr' = get_type_expression expr' in
     let%bind () =
       trace_strong (type_error
                       ~msg:"while condition isn't of type bool"
                       ~expected:(O.t_bool ())
                       ~actual:t_expr'
-                      ~expression:expr
+                      ~expression:condition
                       expr'.location) @@
-      Ast_typed.assert_type_value_eq (t_bool () , t_expr') in
-    let t_body' = get_type_annotation body' in
+      Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in
+    let t_body' = get_type_expression body' in
     let%bind () =
       trace_strong (type_error
                      ~msg:"while body isn't of unit type"
@@ -769,71 +755,38 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
                      ~actual:t_body'
                      ~expression:body
                      body'.location) @@
-      Ast_typed.assert_type_value_eq (t_unit () , t_body') in
-    return (O.E_loop (expr' , body')) (t_unit ())
-  | E_assign (name , path , expr) ->
-    let%bind typed_name =
-      let%bind ele = Environment.get_trace name e in
-      ok @@ make_n_t name ele.type_value in
-    let%bind (assign_tv , path') =
-      let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path ->
-        match cur_path with
-        | Access_tuple index -> (
-            let%bind tpl = get_t_tuple prec_tv in
-            let%bind tv' =
-              trace_option (bad_tuple_index index ae prec_tv ae.location) @@
-              List.nth_opt tpl index in
-            ok (tv' , prec_path @ [O.Access_tuple index])
-          )
-        | Access_record property -> (
-            let%bind m = get_t_record prec_tv in
-            let%bind tv' =
-              trace_option (bad_record_access (Label property) ae prec_tv ae.location) @@
-              I.LMap.find_opt (Label property) m in
-            ok (tv' , prec_path @ [O.Access_record property])
-          )
-      in
-      bind_fold_list aux (typed_name.type_value , []) path in
-    let%bind expr' = type_expression' e ~tv_opt:assign_tv expr in
-    let t_expr' = get_type_annotation expr' in
-    let%bind () =
-      trace_strong (type_error
-                     ~msg:"type of the expression to assign doesn't match left-hand-side"
-                     ~expected:assign_tv
-                     ~actual:t_expr'
-                     ~expression:expr
-                     expr'.location) @@
-      Ast_typed.assert_type_value_eq (assign_tv , t_expr') in
-    return (O.E_assign (typed_name , path' , expr')) (t_unit ())
-  | E_let_in {binder ; rhs ; result; inline} ->
-    let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in
+      Ast_typed.assert_type_expression_eq (t_unit () , t_body') in
+    return (O.E_loop {condition=expr'; body=body'}) (t_unit ())
+  | E_let_in {let_binder ; rhs ; let_result; inline} ->
+    let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
     let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in
-    let e' = Environment.add_ez_declaration (fst binder) rhs e in
-    let%bind result = type_expression' e' result in
-    return (E_let_in {binder = fst binder; rhs; result; inline}) result.type_annotation
-  | E_ascription (expr , te) ->
-    let%bind tv = evaluate_type e te in
-    let%bind expr' = type_expression' ~tv_opt:tv e expr in
+    let let_binder = fst let_binder in
+    let e' = Environment.add_ez_declaration (let_binder) rhs e in
+    let%bind let_result = type_expression' e' let_result in
+    return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
+  | E_ascription {anno_expr; type_annotation} ->
+    let%bind tv = evaluate_type e type_annotation in
+    let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in
     let%bind type_annotation =
       O.merge_annotation
         (Some tv)
-        (Some expr'.type_annotation)
+        (Some expr'.type_expression)
         (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in
     (* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
     let%bind () =
       match tv_opt with
       | None -> ok ()
-      | Some tv' -> O.assert_type_value_eq (tv' , type_annotation) in
-    ok @@ {expr' with type_annotation}
+      | Some tv' -> O.assert_type_expression_eq (tv' , type_annotation) in
+    ok {expr' with type_expression=type_annotation}
 
 
-and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
+and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
   let%bind typer = Operators.Typer.constant_typers name in
   let%bind tv = typer lst tv_opt in
   ok(name, tv)
 
-let untype_type_value (t:O.type_value) : (I.type_expression) result =
-  match t.simplified with
+let untype_type_expression (t:O.type_expression) : (I.type_expression) result =
+  match t.type_meta with
   | Some s -> ok s
   | _ -> fail @@ internal_assertion_failure "trying to untype generated type"
 
@@ -841,6 +794,7 @@ let untype_literal (l:O.literal) : I.literal result =
   let open I in
   match l with
   | Literal_unit -> ok Literal_unit
+  | Literal_void -> ok Literal_void
   | Literal_bool b -> ok (Literal_bool b)
   | Literal_nat n -> ok (Literal_nat n)
   | Literal_timestamp n -> ok (Literal_timestamp n)
@@ -849,43 +803,38 @@ let untype_literal (l:O.literal) : I.literal result =
   | Literal_string s -> ok (Literal_string s)
   | Literal_signature s -> ok (Literal_signature s)
   | Literal_key s -> ok (Literal_key s)
+
   | Literal_key_hash s -> ok (Literal_key_hash s)
   | Literal_chain_id s -> ok (Literal_chain_id s)
   | Literal_bytes b -> ok (Literal_bytes b)
   | Literal_address s -> ok (Literal_address s)
   | Literal_operation s -> ok (Literal_operation s)
 
-let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
+let rec untype_expression (e:O.expression) : (I.expression) result =
   let open I in
   let return e = ok e in
-  match e.expression with
+  match e.expression_content with
   | E_literal l ->
       let%bind l = untype_literal l in
       return (e_literal l)
-  | E_constant (const, lst) ->
-      let%bind lst' = bind_map_list untype_expression lst in
-      return (e_constant const lst')
+  | E_constant {cons_name;arguments} ->
+      let%bind lst' = bind_map_list untype_expression arguments in
+      return (e_constant cons_name lst')
   | E_variable n ->
-      return (e_variable n)
-  | E_application (f, arg) ->
-      let%bind f' = untype_expression f in
-      let%bind arg' = untype_expression arg in
+      return (e_variable (n))
+  | E_application {expr1;expr2} ->
+      let%bind f' = untype_expression expr1 in
+      let%bind arg' = untype_expression expr2 in
       return (e_application f' arg')
-  | E_lambda {binder ; body} -> (
-      let%bind io = get_t_function e.type_annotation in
-      let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
-      let%bind result = untype_expression body in
-      return (e_lambda binder (Some input_type) (Some output_type) result)
+  | E_lambda {binder ; result} -> (
+      let%bind io = get_t_function e.type_expression in
+      let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in
+      let%bind result = untype_expression result in
+      return (e_lambda (binder) (Some input_type) (Some output_type) result)
     )
-  | E_tuple lst ->
-      let%bind lst' = bind_list
-        @@ List.map untype_expression lst in
-      return (e_tuple lst')
-  | E_tuple_accessor (tpl, ind)  ->
-      let%bind tpl' = untype_expression tpl in
-      return (e_accessor tpl' [Access_tuple ind])
-  | E_constructor ( Constructor n, p) ->
-      let%bind p' = untype_expression p in
+  | E_constructor {constructor; element} ->
+      let%bind p' = untype_expression element in
+      let Constructor n = constructor in
       return (e_constructor n p')
   | E_record r ->
     let aux ( Label k ,v) = (k, v) in
@@ -893,10 +842,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
     let%bind r' = bind_smap
       @@ Map.String.map untype_expression r in
     return (e_record r')
-  | E_record_accessor (r, Label s) ->
-      let%bind r' = untype_expression r in
-      return (e_accessor r' [Access_record s])
-  | E_record_update (r, (l,e)) ->
+  | E_record_accessor {expr; label} ->
+      let%bind r' = untype_expression expr in
+      let Label s = label in
+      return (e_accessor r' s)
+  | E_record_update {record=r; path=l; update=e} ->
     let%bind r' = untype_expression r in
     let%bind e = untype_expression e in 
     let Label l = l in
@@ -916,20 +866,18 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
   | E_look_up dsi ->
       let%bind (a , b) = bind_map_pair untype_expression dsi in
       return (e_look_up a b)
-  | E_matching (ae, m) ->
-      let%bind ae' = untype_expression ae in
-      let%bind m' = untype_matching untype_expression m in
+  | E_matching {matchee;cases} ->
+      let%bind ae' = untype_expression matchee in
+      let%bind m' = untype_matching untype_expression cases in
       return (e_matching ae' m')
-  | E_sequence _
-  | E_loop _
-  | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
-  | E_let_in {binder; rhs; result; inline} ->
-      let%bind tv = untype_type_value rhs.type_annotation in
+  | E_loop _-> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
+  | E_let_in {let_binder;rhs;let_result; inline} ->
+      let%bind tv = untype_type_expression rhs.type_expression in
       let%bind rhs = untype_expression rhs in
-      let%bind result = untype_expression result in
-      return (e_let_in (binder , (Some tv)) inline rhs result)
+      let%bind result = untype_expression let_result in
+      return (I.e_let_in (let_binder , (Some tv)) false inline rhs result)
 
-and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
+and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
   let open I in
   match m with
   | Match_bool {match_true ; match_false} ->

src/passes/4-typer-old/typer.mli

@@ -41,14 +41,14 @@ end
 val type_program : I.program -> (O.program * Solver.state) result
 val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result
 (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
-val evaluate_type : environment -> I.type_expression -> O.type_value result
-val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
-val type_constant : I.constant -> O.type_value list -> O.type_value option -> (O.constant * O.type_value) result
+val evaluate_type : environment -> I.type_expression -> O.type_expression result
+val type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
+val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
 (*
 val untype_type_value : O.type_value -> (I.type_expression) result
 val untype_literal : O.literal -> I.literal result
 *)
-val untype_expression : O.annotated_expression -> I.expression result
+val untype_expression : O.expression -> I.expression result
 (*
 val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
 *)

src/passes/4-typer/typer.mli

@@ -12,5 +12,5 @@ module Solver = Typer_new.Solver
 type environment = Environment.t
 
 val type_program : I.program -> (O.program * Solver.state) result
-val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
-val untype_expression : O.annotated_expression -> I.expression result
+val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
+val untype_expression : O.expression -> I.expression result

src/passes/6-transpiler/helpers.ml

@@ -21,9 +21,9 @@ let map_of_kv_list lst =
   let open Map.String in
   List.fold_left (fun prev (k, v) -> add k v prev) empty lst
 
-let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
+let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
   let open Append_tree in
-  let rec aux tv : (string * value * AST.type_value) result=
+  let rec aux tv : (string * value * AST.type_expression) result=
     match tv with
     | Leaf (Constructor k, t), v -> ok (k, v, t)
     | Node {a}, D_left v -> aux (a, v)
@@ -33,9 +33,9 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
   let%bind (s, v, t) = aux (tree, v) in
   ok (s, v, t)
 
-let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
+let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
   let open Append_tree in
-  let rec aux tv : ((value * AST.type_value) list) result =
+  let rec aux tv : ((value * AST.type_expression) list) result =
     match tv with
     | Leaf t, v -> ok @@ [v, t]
     | Node {a;b}, D_pair (va, vb) ->
@@ -48,7 +48,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
 
 let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
   let open Append_tree in
-  let rec aux tv : ((AST.label * (value * AST.type_value)) list) result =
+  let rec aux tv : ((AST.label * (value * AST.type_expression)) list) result =
     match tv with
     | Leaf (s, t), v -> ok @@ [s, (v, t)]
     | Node {a;b}, D_pair (va, vb) ->

src/passes/6-transpiler/transpiler.ml

@@ -102,32 +102,27 @@ them. please report this to the developers." in
     ] in
     error ~data title content
 
-  let not_found content =
-    let title () = "Not_found" in
-    let content () = content in
-    let data = [
-    ] in
-    error ~data title content
 end
 open Errors
 
-let rec transpile_type (t:AST.type_value) : type_value result =
-  match t.type_value' with
+let rec transpile_type (t:AST.type_expression) : type_value result =
+  match t.type_content with
   | T_variable (name) -> fail @@ no_type_variable @@ name
-  | T_constant (TC_bool) -> ok (T_base Base_bool)
-  | T_constant (TC_int) -> ok (T_base Base_int)
-  | T_constant (TC_nat) -> ok (T_base Base_nat)
-  | T_constant (TC_mutez) -> ok (T_base Base_mutez)
-  | T_constant (TC_string) -> ok (T_base Base_string)
-  | T_constant (TC_bytes) -> ok (T_base Base_bytes)
-  | T_constant (TC_address) -> ok (T_base Base_address)
-  | T_constant (TC_timestamp) -> ok (T_base Base_timestamp)
-  | T_constant (TC_unit) -> ok (T_base Base_unit)
-  | T_constant (TC_operation) -> ok (T_base Base_operation)
-  | T_constant (TC_signature) -> ok (T_base Base_signature)
-  | T_constant (TC_key) -> ok (T_base Base_key)
-  | T_constant (TC_key_hash) -> ok (T_base Base_key_hash)
-  | T_constant (TC_chain_id) -> ok (T_base Base_chain_id)
+  | T_constant (TC_bool) -> ok (T_base TC_bool)
+  | T_constant (TC_int) -> ok (T_base TC_int)
+  | T_constant (TC_nat) -> ok (T_base TC_nat)
+  | T_constant (TC_mutez) -> ok (T_base TC_mutez)
+  | T_constant (TC_string) -> ok (T_base TC_string)
+  | T_constant (TC_bytes) -> ok (T_base TC_bytes)
+  | T_constant (TC_address) -> ok (T_base TC_address)
+  | T_constant (TC_timestamp) -> ok (T_base TC_timestamp)
+  | T_constant (TC_unit) -> ok (T_base TC_unit)
+  | T_constant (TC_operation) -> ok (T_base TC_operation)
+  | T_constant (TC_signature) -> ok (T_base TC_signature)
+  | T_constant (TC_key) -> ok (T_base TC_key)
+  | T_constant (TC_key_hash) -> ok (T_base TC_key_hash)
+  | T_constant (TC_chain_id) -> ok (T_base TC_chain_id)
+  | T_constant (TC_void)     -> ok (T_base TC_void)
   | T_operator (TC_contract x) ->
       let%bind x' = transpile_type x in
       ok (T_contract x')
@@ -160,7 +155,7 @@ let rec transpile_type (t:AST.type_value) : type_value result =
         ok (None, T_or (a, b))
       in
       let%bind m' = Append_tree.fold_ne
-                      (fun (Constructor ann, a) ->
+                      (fun (Stage_common.Types.Constructor ann, a) ->
                         let%bind a = transpile_type a in
                         ok (Some (String.uncapitalize_ascii ann), a))
                       aux node in
@@ -173,49 +168,22 @@ let rec transpile_type (t:AST.type_value) : type_value result =
         ok (None, T_pair (a, b))
       in
       let%bind m' = Append_tree.fold_ne
-                      (fun (Label ann, a) ->
+                      (fun (Stage_common.Types.Label ann, a) ->
                         let%bind a = transpile_type a in
                         ok (Some ann, a))
                       aux node in
       ok @@ snd m'
-  | T_operator (TC_tuple lst) ->
-      let node = Append_tree.of_list lst in
-      let aux a b : type_value result =
-        let%bind a = a in
-        let%bind b = b in
-        ok (T_pair ((None, a), (None, b)))
-      in
-      Append_tree.fold_ne transpile_type aux node
-  | T_arrow (param, result) -> (
-      let%bind param' = transpile_type param in
-      let%bind result' = transpile_type result in
-      ok (T_function (param', result'))
+  | T_arrow {type1;type2} -> (
+      let%bind param' = transpile_type type1 in
+      let%bind result' = transpile_type type2 in
+      ok (T_function (param',result'))
     )
 
-let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [`Left | `Right]) list result = fun ty tys ind ->
-  let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tys in
-  let%bind path =
-    let aux (i , _) = i = ind in
-    trace_option (corner_case ~loc:__LOC__ "tuple access leaf") @@
-    Append_tree.exists_path aux node_tv in
-  let lr_path = List.map (fun b -> if b then `Right else `Left) path in
-  let%bind (_ , lst) =
-    let aux = fun (ty' , acc) cur ->
-      let%bind (a , b) =
-        trace_strong (corner_case ~loc:__LOC__ "tuple access pair") @@
-        Mini_c.get_t_pair ty' in
-      match cur with
-      | `Left -> ok (a , acc @ [(a , `Left)])
-      | `Right -> ok (b , acc @ [(b , `Right)])
-    in
-    bind_fold_list aux (ty , []) lr_path in
-  ok lst
-
-let record_access_to_lr : type_value -> type_value AST.label_map -> label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
+let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
   let tys = kv_list_of_lmap tym in
   let node_tv = Append_tree.of_list tys in
   let%bind path =
-    let aux (Label i , _) = let Label ind = ind in i = ind in
+    let aux (i , _) = i = ind  in
     trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
     Append_tree.exists_path aux node_tv in
   let lr_path = List.map (fun b -> if b then `Right else `Left) path in
@@ -245,16 +213,17 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
   | Literal_chain_id s -> D_string s
   | Literal_operation op -> D_operation op
   | Literal_unit -> D_unit
+  | Literal_void -> D_none
 
 and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
   transpile_type ele.type_value
 
-and tree_of_sum : AST.type_value -> (constructor * AST.type_value) Append_tree.t result = fun t ->
+and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
   let%bind map_tv = get_t_sum t in
   ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv
 
-and transpile_annotated_expression (ae:AST.annotated_expression) : expression result =
-  let%bind tv = transpile_type ae.type_annotation in
+and transpile_annotated_expression (ae:AST.expression) : expression result =
+  let%bind tv = transpile_type ae.type_expression in
   let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
   let f = transpile_annotated_expression in
   let info =
@@ -262,11 +231,11 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
     let content () = Format.asprintf "%a" Location.pp ae.location in
     info title content in
   trace info @@
-  match ae.expression with
-  | E_let_in {binder; rhs; result; inline} ->
+  match ae.expression_content with
+  | E_let_in {let_binder; rhs; let_result; inline} ->
     let%bind rhs' = transpile_annotated_expression rhs in
-    let%bind result' = transpile_annotated_expression result in
-    return (E_let_in ((binder, rhs'.type_value), inline, rhs', result'))
+    let%bind result' = transpile_annotated_expression let_result in
+    return (E_let_in ((let_binder, rhs'.type_value), inline, rhs', result'))
   | E_literal l -> return @@ E_literal (transpile_literal l)
   | E_variable name -> (
       let%bind ele =
@@ -275,21 +244,21 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind tv = transpile_environment_element_type ele in
       return ~tv @@ E_variable (name)
     )
-  | E_application (a, b) ->
-      let%bind a = transpile_annotated_expression a in
-      let%bind b = transpile_annotated_expression b in
+  | E_application {expr1;expr2} ->
+      let%bind a = transpile_annotated_expression expr1 in
+      let%bind b = transpile_annotated_expression expr2 in
       return @@ E_application (a, b)
-  | E_constructor (m, param) -> (
-      let%bind param' = transpile_annotated_expression param in
+  | E_constructor {constructor;element} -> (
+      let%bind param' = transpile_annotated_expression element in
       let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
       let%bind node_tv =
         trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
-        tree_of_sum ae.type_annotation in
+        tree_of_sum ae.type_expression in
       let leaf (k, tv) : (expression' option * type_value) result =
-        if k = m then (
+        if k = constructor then (
           let%bind _ =
             trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
-            @@ AST.assert_type_value_eq (tv, param.type_annotation) in
+            @@ AST.assert_type_expression_eq (tv, element.type_expression) in
           ok (Some (param'_expr), param'_tv)
         ) else (
           let%bind tv = transpile_type tv in
@@ -301,8 +270,8 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         match (a, b) with
         | (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b)))
         | (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
-        | (Some v, a), (None, b) -> ok (Some (E_constant (C_LEFT, [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
-        | (None, a), (Some v, b) -> ok (Some (E_constant (C_RIGHT, [Combinators.Expression.make_tpl (v, b)])), T_or ((None, a), (None, b)))
+        | (Some v, a), (None, b) -> ok (Some (E_constant {cons_name=C_LEFT ;arguments= [Combinators.Expression.make_tpl (v, a)]}), T_or ((None, a), (None, b)))
+        | (None, a), (Some v, b) -> ok (Some (E_constant {cons_name=C_RIGHT;arguments= [Combinators.Expression.make_tpl (v, b)]}), T_or ((None, a), (None, b)))
       in
       let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
       let%bind ae =
@@ -310,36 +279,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
           ae_opt in
       return ~tv ae
     )
-  | E_tuple lst -> (
-      let node = Append_tree.of_list lst in
-      let aux (a:expression result) (b:expression result) : expression result =
-        let%bind a = a in
-        let%bind b = b in
-        let a_ty = Combinators.Expression.get_type a in
-        let b_ty = Combinators.Expression.get_type b in
-        let tv = T_pair ((None, a_ty) , (None, b_ty)) in
-        return ~tv @@ E_constant (C_PAIR, [a; b])
-      in
-      Append_tree.fold_ne (transpile_annotated_expression) aux node
-    )
-  | E_tuple_accessor (tpl, ind) -> (
-      let%bind ty' = transpile_type tpl.type_annotation in
-      let%bind ty_lst =
-        trace_strong (corner_case ~loc:__LOC__ "transpiler: E_tuple_accessor: not a tuple") @@
-        get_t_tuple tpl.type_annotation in
-      let%bind ty'_lst = bind_map_list transpile_type ty_lst in
-      let%bind path =
-        trace_strong (corner_case ~loc:__LOC__ "tuple access") @@
-        tuple_access_to_lr ty' ty'_lst ind in
-      let aux = fun pred (ty, lr) ->
-        let c = match lr with
-          | `Left  -> C_CAR
-          | `Right -> C_CDR in
-        Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind tpl' = transpile_annotated_expression tpl in
-      let expr = List.fold_left aux tpl' path in
-      ok expr
-    )
   | E_record m -> (
       let node = Append_tree.of_list @@ list_of_lmap m in
       let aux a b : expression result =
@@ -348,51 +287,51 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         let a_ty = Combinators.Expression.get_type a in
         let b_ty = Combinators.Expression.get_type b in
         let tv = T_pair ((None, a_ty) , (None, b_ty)) in
-        return ~tv @@ E_constant (C_PAIR, [a; b])
+        return ~tv @@ E_constant {cons_name=C_PAIR;arguments=[a; b]}
       in
       trace_strong (corner_case ~loc:__LOC__ "record build") @@
       Append_tree.fold_ne (transpile_annotated_expression) aux node
     )
-  | E_record_accessor (record, property) ->
-      let%bind ty' = transpile_type (get_type_annotation record) in
+  | E_record_accessor {expr; label} ->
+      let%bind ty' = transpile_type (get_type_expression expr) in
       let%bind ty_lmap =
         trace_strong (corner_case ~loc:__LOC__ "not a record") @@
-        get_t_record (get_type_annotation record) in
-      let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in
+        get_t_record (get_type_expression expr) in
+      let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
       let%bind path =
         trace_strong (corner_case ~loc:__LOC__ "record access") @@
-        record_access_to_lr ty' ty'_lmap property in
+        record_access_to_lr ty' ty'_lmap label in
       let aux = fun pred (ty, lr) ->
         let c = match lr with
           | `Left  -> C_CAR
           | `Right -> C_CDR in
-        Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind record' = transpile_annotated_expression record in
+        Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in
+      let%bind record' = transpile_annotated_expression expr in
       let expr = List.fold_left aux record' path in
       ok expr
-  | E_record_update (record, (l,expr)) -> 
-      let%bind ty' = transpile_type (get_type_annotation record) in 
+  | E_record_update {record; path; update} -> 
+      let%bind ty' = transpile_type (get_type_expression record) in 
       let%bind ty_lmap =
         trace_strong (corner_case ~loc:__LOC__ "not a record") @@
-        get_t_record (get_type_annotation record) in
-      let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in
+        get_t_record (get_type_expression record) in
+      let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
       let%bind path = 
         trace_strong (corner_case ~loc:__LOC__ "record access") @@
-        record_access_to_lr ty' ty'_lmap l in
-      let path' = List.map snd path in
-      let%bind expr' = transpile_annotated_expression expr in
+        record_access_to_lr ty' ty'_lmap path in
+      let path = List.map snd path in
+      let%bind update = transpile_annotated_expression update in
       let%bind record = transpile_annotated_expression record in
-      return @@ E_update (record, (path',expr')) 
-  | E_constant (name , lst) -> (
+      return @@ E_record_update (record, path, update)
+  | E_constant {cons_name=name; arguments=lst} -> (
       let iterator_generator iterator_name =
-        let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) =
-          let%bind body' = transpile_annotated_expression l.body in
-          let%bind (input , _) = AST.get_t_function f.type_annotation in
+        let lambda_to_iterator_body (f : AST.expression) (l : AST.lambda) =
+          let%bind body' = transpile_annotated_expression l.result in
+          let%bind (input , _) = AST.get_t_function f.type_expression in
           let%bind input' = transpile_type input in
           ok ((l.binder , input') , body')
         in
-        let expression_to_iterator_body (f : AST.annotated_expression) =
-          match f.expression with
+        let expression_to_iterator_body (f : AST.expression) =
+          match f.expression_content with
           | E_lambda l -> lambda_to_iterator_body f l
           | E_variable v -> (
               let%bind elt =
@@ -400,7 +339,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
                 AST.Environment.get_opt v f.environment in
               match elt.definition with
               | ED_declaration (f , _) -> (
-                  match f.expression with
+                  match f.expression_content with
                   | E_lambda l -> lambda_to_iterator_body f l
                   | _ -> fail @@ unsupported_iterator f.location
                 )
@@ -408,7 +347,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
             )
           | _ -> fail @@ unsupported_iterator f.location
         in
-        fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with
+        fun (lst : AST.expression list) -> match (lst , iterator_name) with
           | [f ; i] , C_ITER | [f ; i] , C_MAP -> (
               let%bind f' = expression_to_iterator_body f in
               let%bind i' = transpile_annotated_expression i in
@@ -434,11 +373,11 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       | (C_MAP_FOLD , lst) -> fold lst
       | _ -> (
           let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
-          return @@ E_constant (name , lst')
+          return @@ E_constant {cons_name=name;arguments=lst'}
         )
     )
   | E_lambda l ->
-    let%bind io = AST.get_t_function ae.type_annotation in
+    let%bind io = AST.get_t_function ae.type_expression in
     transpile_lambda l io
   | E_list lst -> (
       let%bind t =
@@ -446,7 +385,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         get_t_list tv in
       let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
-        return @@ E_constant (C_CONS, [cur ; prev]) in
+        return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
       let%bind (init : expression) = return @@ E_make_empty_list t in
       bind_fold_right_list aux init lst'
     )
@@ -456,7 +395,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         get_t_set tv in
       let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
-        return @@ E_constant (C_SET_ADD, [cur ; prev]) in
+        return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
       let%bind (init : expression) = return @@ E_make_empty_set t in
       bind_fold_list aux init lst'
     )
@@ -464,12 +403,12 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind (src, dst) =
         trace_strong (corner_case ~loc:__LOC__ "not a map") @@
         Mini_c.Combinators.get_t_map tv in
-      let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
+      let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
         let%bind prev' = prev in
         let%bind (k', v') =
           let v' = e_a_some v ae.environment in
           bind_map_pair (transpile_annotated_expression) (k , v') in
-        return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
+        return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
       in
       let init = return @@ E_make_empty_map (src, dst) in
       List.fold_left aux init m
@@ -478,63 +417,26 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind (src, dst) =
         trace_strong (corner_case ~loc:__LOC__ "not a map") @@
         Mini_c.Combinators.get_t_big_map tv in
-      let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
+      let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
         let%bind prev' = prev in
         let%bind (k', v') =
           let v' = e_a_some v ae.environment in
           bind_map_pair (transpile_annotated_expression) (k , v') in
-        return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
+        return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
       in
       let init = return @@ E_make_empty_big_map (src, dst) in
       List.fold_left aux init m
     )
   | E_look_up dsi -> (
       let%bind (ds', i') = bind_map_pair f dsi in
-      return @@ E_constant (C_MAP_FIND_OPT, [i' ; ds'])
+      return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
     )
-  | E_sequence (a , b) -> (
-      let%bind a' = transpile_annotated_expression a in
-      let%bind b' = transpile_annotated_expression b in
-      return @@ E_sequence (a' , b')
-    )
-  | E_loop (expr , body) -> (
-      let%bind expr' = transpile_annotated_expression expr in
+  | E_loop {condition; body} -> (
+      let%bind expr' = transpile_annotated_expression condition in
       let%bind body' = transpile_annotated_expression body in
       return @@ E_while (expr' , body')
     )
-  | E_assign (typed_name , path , expr) -> (
-      let ty = typed_name.type_value in
-      let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
-        fun (prev, acc) cur ->
-          let%bind ty' = transpile_type prev in
-          match cur with
-          | Access_tuple ind -> (
-              let%bind ty_lst =
-                trace_strong (corner_case ~loc:__LOC__ "transpiler: E_assign: Access_tuple: not a tuple") @@
-                AST.Combinators.get_t_tuple prev in
-              let%bind ty'_lst = bind_map_list transpile_type ty_lst in
-              let%bind path = tuple_access_to_lr ty' ty'_lst ind in
-              let path' = List.map snd path in
-              ok (List.nth ty_lst ind, acc @ path')
-            )
-          | Access_record prop -> (
-            let%bind ty_map =
-                trace_strong (corner_case ~loc:__LOC__ "not a record") @@
-                AST.Combinators.get_t_record prev in
-              let%bind ty'_map = bind_map_lmap transpile_type ty_map in
-              let%bind path = record_access_to_lr ty' ty'_map (Label prop) in
-              let path' = List.map snd path in
-            let%bind prop_in_ty_map = trace_option
-                (Errors.not_found "acessing prop in ty_map [TODO: better error message]")
-                (AST.LMap.find_opt (Label prop) ty_map) in
-            ok (prop_in_ty_map, acc @ path')
-          )
-      in
-      let%bind (_, path) = bind_fold_list aux (ty, []) path in
-      let%bind expr' = transpile_annotated_expression expr in
-      return (E_assignment (typed_name.type_name, path, expr'))
-    )
-  | E_matching (expr, m) -> (
+  | E_matching {matchee=expr; cases=m} -> (
       let%bind expr' = transpile_annotated_expression expr in
       match m with
       | Match_bool {match_true ; match_false} ->
@@ -612,18 +514,20 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
   )
 
 and transpile_lambda l (input_type , output_type) =
-  let { binder ; body } : AST.lambda = l in
-  let%bind result' = transpile_annotated_expression body in
+  let { binder ; result } : AST.lambda = l in
+  let%bind result' = transpile_annotated_expression result in
   let%bind input = transpile_type input_type in
   let%bind output = transpile_type output_type in
   let tv = Combinators.t_function input output in
+  let binder = binder in 
   let closure = E_closure { binder; body = result'} in
   ok @@ Combinators.Expression.make_tpl (closure , tv)
 
 let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
   match d with
-  | Declaration_constant ({name;annotated_expression} , inline , _) ->
-      let%bind expression = transpile_annotated_expression annotated_expression in
+  | Declaration_constant (name,expression, inline, _) ->
+      let name = name in
+      let%bind expression = transpile_annotated_expression expression in
       let tv = Combinators.Expression.get_type expression in
       let env' = Environment.add (name, tv) env in
       ok @@ ((name, inline, expression), environment_wrap env env')
@@ -658,9 +562,9 @@ let check_storage f ty loc : (anon_function * _) result =
       if aux (snd storage) false then ok (f, ty) else fail @@ bad_big_map loc
     | _ -> ok (f, ty)
 
-let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
+let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
   let open Append_tree in
-  let rec aux tv : (string * value * AST.type_value) result=
+  let rec aux tv : (string * value * AST.type_expression) result=
     match tv with
     | Leaf (k, t), v -> ok (k, v, t)
     | Node {a}, D_left v -> aux (a, v)
@@ -670,9 +574,9 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
   let%bind (s, v, t) = aux (tree, v) in
   ok (s, v, t)
 
-let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
+let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
   let open Append_tree in
-  let rec aux tv : ((value * AST.type_value) list) result =
+  let rec aux tv : ((value * AST.type_expression) list) result =
     match tv with
     | Leaf t, v -> ok @@ [v, t]
     | Node {a;b}, D_pair (va, vb) ->
@@ -685,7 +589,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
 
 let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
   let open Append_tree in
-  let rec aux tv : ((string * (value * AST.type_value)) list) result =
+  let rec aux tv : ((string * (value * AST.type_expression)) list) result =
     match tv with
     | Leaf (s, t), v -> ok @@ [s, (v, t)]
     | Node {a;b}, D_pair (va, vb) ->

src/passes/6-transpiler/transpiler.mli

@@ -35,7 +35,7 @@ val translate_literal : AST.literal -> value
 val transpile_environment_element_type : AST.environment_element -> type_value result
 val tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result
 *)
-val transpile_annotated_expression : AST.annotated_expression -> expression result
+val transpile_annotated_expression : AST.expression -> expression result
 (*
 val transpile_lambda : AST.lambda -> expression result
 val transpile_declaration : environment -> AST.declaration -> toplevel_statement result
@@ -49,7 +49,7 @@ val translate_main : AST.lambda -> Location.t ->( anon_function * ( type_value *
 (* From an expression [expr], build the expression [fun () -> expr] *)
 val translate_entry : AST.program -> string -> ( anon_function * ( type_value * type_value )) result
 *)
-val extract_constructor : value -> ( string * AST.type_value ) Append_tree.t' -> (string * value * AST.type_value) result
-val extract_tuple : value -> AST.type_value Append_tree.t' -> (value * AST.type_value) list result
-val extract_record : value -> ( string * AST.type_value ) Append_tree.t' -> ( string * ( value * AST.type_value )) list result
-val untranspile : value -> AST.type_value -> AST.annotated_expression result
+val extract_constructor : value -> ( string * AST.type_expression ) Append_tree.t' -> (string * value * AST.type_expression) result
+val extract_tuple : value -> AST.type_expression Append_tree.t' -> (value * AST.type_expression) list result
+val extract_record : value -> ( string * AST.type_expression ) Append_tree.t' -> ( string * ( value * AST.type_expression)) list result
+val untranspile : value -> AST.type_expression -> AST.expression result

src/passes/6-transpiler/untranspiler.ml

@@ -40,10 +40,10 @@ end
 
 open Errors
 
-let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result =
+let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result =
   let open! AST in
   let return e = ok (make_a_e_empty e t) in
-  match t.type_value' with
+  match t.type_content with
   | T_constant type_constant -> (
     match type_constant with
     | TC_unit -> (
@@ -95,6 +95,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
         return (E_literal (Literal_bytes n))
       )
     | TC_address -> (
+
         let%bind n =
           trace_strong (wrong_mini_c_value "address" v) @@
           get_string v in
@@ -124,6 +125,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
         get_string v in
       return (E_literal (Literal_chain_id n))
     )
+    | TC_void -> (
+      let%bind () =
+        trace_strong (wrong_mini_c_value "void" v) @@
+        get_unit v in
+      return (E_literal (Literal_void))
+    )
     |  TC_signature -> (
       let%bind n =
         trace_strong (wrong_mini_c_value "signature" v) @@
@@ -176,6 +183,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
           bind_map_list aux lst in
         return (E_list lst')
       )
+    | TC_arrow _ -> (
+        let%bind n =
+          trace_strong (wrong_mini_c_value "lambda as string" v) @@
+          get_string v in
+        return (E_literal (Literal_string n))
+      )
     | TC_set ty -> (
         let%bind lst =
           trace_strong (wrong_mini_c_value "set" v) @@
@@ -187,22 +200,6 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
       )
     | TC_contract _ ->
       fail @@ bad_untranspile "contract" v
-    | TC_arrow _ -> (
-        let%bind n =
-          trace_strong (wrong_mini_c_value "lambda as string" v) @@
-          get_string v in
-        return (E_literal (Literal_string n))
-      )
-    | TC_tuple lst ->
-      let%bind node = match Append_tree.of_list lst with
-        | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
-        | Full t -> ok t in
-      let%bind tpl =
-        trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
-        extract_tuple v node in
-      let%bind tpl' = bind_list
-        @@ List.map (fun (x, y) -> untranspile x y) tpl in
-      return (E_tuple tpl')
   )
   | T_sum m ->
       let lst = kv_list_of_cmap m in
@@ -214,7 +211,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
         trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
         extract_constructor v node in
       let%bind sub = untranspile v tv in
-      return (E_constructor (Constructor name, sub))
+      return (E_constructor {constructor=Constructor name;element=sub})
   | T_record m ->
       let lst = kv_list_of_lmap m in
       let%bind node = match Append_tree.of_list lst with

src/passes/7-self_mini_c/helpers.ml

@@ -32,8 +32,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
     ok init'
   )
   | E_literal _ -> ok init'
-  | E_constant (_, lst) -> (
-      let%bind res = bind_fold_list self init' lst in
+  | E_constant (c) -> (
+      let%bind res = bind_fold_list self init' c.arguments in
       ok res
   )
   | E_closure af -> (
@@ -84,7 +84,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
       let%bind res = self init' exp in
       ok res
   )
-  | E_update (r, (_,e)) -> (
+  | E_record_update (r, _, e) -> (
       let%bind res = self init' r in
       let%bind res = self res e in
       ok res
@@ -102,9 +102,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
   | E_make_empty_big_map _
   | E_make_empty_list _
   | E_make_empty_set _ as em -> return em
-  | E_constant (name, lst) -> (
-      let%bind lst' = bind_map_list self lst in
-      return @@ E_constant (name,lst')
+  | E_constant (c) -> (
+      let%bind lst = bind_map_list self c.arguments in
+      return @@ E_constant {cons_name = c.cons_name; arguments = lst}
   )
   | E_closure af -> (
       let%bind body = self af.body in
@@ -154,10 +154,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
       let%bind exp' = self exp in
       return @@ E_assignment (s, lrl, exp')
   )
-  | E_update (r, (l,e)) -> (
+  | E_record_update (r, l, e) -> (
       let%bind r = self r in
       let%bind e = self e in
-      return @@ E_update(r,(l,e))
+      return @@ E_record_update(r, l, e)
   )
 
 let map_sub_level_expression : mapper -> expression -> expression result = fun f e ->

src/passes/7-self_mini_c/michelson_restrictions.ml

@@ -19,7 +19,7 @@ let self_in_lambdas : expression -> expression result =
     | E_closure {binder=_ ; body} ->
       let%bind _self_in_lambdas = Helpers.map_expression
         (fun e -> match e.content with
-        | E_constant (C_SELF_ADDRESS, _) as c -> fail (bad_self_address c)
+        | E_constant {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c)
         | _ -> ok e)
         body in
       ok e

src/passes/7-self_mini_c/self_mini_c.ml

@@ -15,7 +15,7 @@ let map_expression :
 
 (* true if the name names a pure constant -- i.e. if uses will be pure
    assuming arguments are pure *)
-let is_pure_constant : constant -> bool =
+let is_pure_constant : constant' -> bool =
   function
   | C_UNIT
   | C_CAR | C_CDR | C_PAIR
@@ -64,10 +64,10 @@ let rec is_pure : expression -> bool = fun e ->
   | E_sequence (e1, e2)
     -> List.for_all is_pure [ e1 ; e2 ]
 
-  | E_constant (c, args)
-    -> is_pure_constant c && List.for_all is_pure args
-  | E_update (r, (_,e))
-    -> is_pure r && is_pure e
+  | E_constant (c)
+    -> is_pure_constant c.cons_name && List.for_all is_pure c.arguments
+  | E_record_update (e, _,up)
+    -> is_pure e && is_pure up
 
   (* I'm not sure about these. Maybe can be tested better? *)
   | E_application _
@@ -79,6 +79,7 @@ let rec is_pure : expression -> bool = fun e ->
      is near... *)
   | E_while _ -> false
 
+
   (* definitely not pure *)
   | E_assignment _ -> false
 
@@ -111,14 +112,14 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -
   match e.content with
   | E_assignment (x, _, e) ->
     it x || self e
-  | E_update (r, (_,e)) ->
+  | E_record_update (r, _, e) ->
     self r || self e
   | E_closure { binder; body } ->
     if ignore_lambdas
     then false
     else self_binder binder body
-  | E_constant (_, args) ->
-    selfs args
+  | E_constant (c) ->
+    selfs c.arguments
   | E_application (f, arg) ->
     selfs [ f ; arg ]
   | E_iterator (_, ((x, _), e1), e2) ->
@@ -236,7 +237,7 @@ let beta : bool ref -> expression -> expression =
     else e
 
   (* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *)
-  | E_constant (C_CAR| C_CDR as const, [ { content = E_constant (C_PAIR, [ e1 ; e2 ]) ; type_value = _ } ]) ->
+  | E_constant {cons_name = C_CAR| C_CDR as const; arguments = [ { content = E_constant {cons_name = C_PAIR; arguments = [ e1 ; e2 ]} ; type_value = _ } ]} ->
     if is_pure e1 && is_pure e2
     then (changed := true ;
           match const with

src/passes/7-self_mini_c/subst.ml

@@ -31,9 +31,9 @@ let rec replace : expression -> var_name -> var_name -> expression =
     let binder = replace_var binder in
     return @@ E_closure { binder ; body }
   | E_skip -> e
-  | E_constant (c, args) ->
-    let args = List.map replace args in
-    return @@ E_constant (c, args)
+  | E_constant (c) ->
+    let args = List.map replace c.arguments in
+    return @@ E_constant {cons_name = c.cons_name; arguments = args}
   | E_application (f, x) ->
     let (f, x) = Tuple.map2 replace (f, x) in
     return @@ E_application (f, x)
@@ -94,10 +94,10 @@ let rec replace : expression -> var_name -> var_name -> expression =
     let v = replace_var v in
     let e = replace e in
     return @@ E_assignment (v, path, e)
-  | E_update (r, (p,e)) ->
+  | E_record_update (r, p, e) ->
     let r = replace r in
     let e = replace e in
-    return @@ E_update (r, (p,e))
+    return @@ E_record_update (r, p, e)
   | E_while (cond, body) ->
     let cond = replace cond in
     let body = replace body in
@@ -126,7 +126,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
   (* hack to avoid reimplementing subst_binder for 2-ary binder in E_if_cons:
      intuitively, we substitute in \hd tl. expr' as if it were \hd. \tl. expr *)
   let subst_binder2 y z expr' =
-    let dummy = T_base Base_unit in
+    let dummy = T_base TC_unit in
     let hack = { content = E_closure { binder = z ; body = expr' } ;
                  type_value = dummy } in
     match subst_binder y hack with
@@ -184,9 +184,9 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
   | E_make_empty_big_map _
   | E_make_empty_list _
   | E_make_empty_set _ as em -> return em
-  | E_constant (name, lst) -> (
-      let lst' = List.map self lst in
-      return @@ E_constant (name,lst')
+  | E_constant (c) -> (
+      let lst = List.map self c.arguments in
+      return @@ E_constant {cons_name = c.cons_name; arguments = lst }
   )
   | E_application farg -> (
       let farg' = Tuple.map2 self farg in
@@ -209,14 +209,14 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
       if Var.equal s x then raise Bad_argument ;
       return @@ E_assignment (s, lrl, exp')
   )
-  | E_update (r, (p,e)) -> (
+  | E_record_update (r, p, e) -> (
     let r' = self r in
     let e' = self e in
-    return @@ E_update(r', (p,e'))
+    return @@ E_record_update(r', p, e')
   )
 
 let%expect_test _ =
-  let dummy_type = T_base Base_unit in
+  let dummy_type = T_base TC_unit in
   let wrap e = { content = e ; type_value = dummy_type } in
 
   let show_subst ~body ~x ~expr =

src/passes/8-compiler/compiler_environment.ml

@@ -10,7 +10,7 @@ let get : environment -> expression_variable -> michelson result = fun e s ->
     let error =
       let title () = "Environment.get" in
       let content () = Format.asprintf "%a in %a"
-          Stage_common.PP.name s 
+          Var.pp s 
           PP.environment e in
       error title content in
     generic_try error @@

src/passes/8-compiler/compiler_program.ml

@@ -27,7 +27,7 @@ end
 open Errors
 
 (* This does not makes sense to me *)
-let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst ->
+let get_operator : constant' -> type_value -> expression list -> predicate result = fun s ty lst ->
   match Operators.Compiler.get_operators s with
   | Ok (x,_) -> ok x
   | Error _ -> (
@@ -114,7 +114,7 @@ let get_operator : constant -> type_value -> expression list -> predicate result
             i_drop ; (* drop the entrypoint... *)
             prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ;
           ]
-      | x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" Stage_common.PP.constant x)
+      | x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" PP.constant x)
     )
 
 let rec translate_value (v:value) ty : michelson result = match v with
@@ -220,7 +220,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
       b' ;
     ]
   )
-  | E_constant(str, lst) ->
+  | E_constant{cons_name=str;arguments= lst} ->
       let module L = Logger.Stateful() in
       let%bind pre_code =
         let aux code expr =
@@ -249,7 +249,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
             pre_code ;
             f ;
           ]
-        | _ -> simple_fail (Format.asprintf "bad arity for %a"  Stage_common.PP.constant str)
+        | _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str)
       in
       let error =
         let title () = "error compiling constant" in
@@ -347,7 +347,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
         ]) in
       return code
     )
-  | E_iterator (name , (v , body) , expr) -> (
+  | E_iterator (name,(v , body) , expr) -> (
       let%bind expr' = translate_expression expr env in
       let%bind body' = translate_expression body (Environment.add v env) in
       match name with
@@ -367,7 +367,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
           return code
         )
       | s -> (
-          let iter = Format.asprintf "iter %a" Stage_common.PP.constant s in
+          let iter = Format.asprintf "iter %a" PP.constant s in
           let error = error (thunk "bad iterator") (thunk iter) in
           fail error
         )
@@ -422,7 +422,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
         i_push_unit ;
       ]
     )
-  | E_update (record, (path, expr)) -> (
+  | E_record_update (record, path, expr) -> (
     let%bind record' = translate_expression record env in
 
     let record_var = Var.fresh () in

src/passes/8-compiler/compiler_program.mli

@@ -14,7 +14,7 @@ type compiled_expression = {
   expr : michelson ;
 }
 
-val get_operator : constant -> type_value -> expression list -> predicate result
+val get_operator : constant' -> type_value -> expression list -> predicate result
 val translate_expression : expression -> environment -> michelson result
 val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result
 val translate_value : value -> type_value -> michelson result 

src/passes/8-compiler/compiler_type.ml

@@ -15,7 +15,7 @@ module Ty = struct
   let tez_k = Mutez_key None
   let int_k = Int_key None
   let string_k = String_key None
-  let key_hash_k = Key_hash_key None
+  let _key_hash_k = Key_hash_key None
   let address_k = Address_key None
   let timestamp_k = Timestamp_key None
   let bytes_k = Bytes_key None
@@ -57,24 +57,24 @@ module Ty = struct
   let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
   let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
 
-  let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
+  let comparable_type_base : type_constant -> ex_comparable_ty result = fun tb ->
     let return x = ok @@ Ex_comparable_ty x in
     match tb with
-    | Base_unit -> fail (not_comparable "unit")
-    | Base_void -> fail (not_comparable "void")
-    | Base_bool -> fail (not_comparable "bool")
-    | Base_nat -> return nat_k
-    | Base_mutez -> return tez_k
-    | Base_int -> return int_k
-    | Base_string -> return string_k
-    | Base_address -> return address_k
-    | Base_timestamp -> return timestamp_k
-    | Base_bytes -> return bytes_k
-    | Base_operation -> fail (not_comparable "operation")
-    | Base_signature -> fail (not_comparable "signature")
-    | Base_key -> fail (not_comparable "key")
-    | Base_key_hash -> return key_hash_k
-    | Base_chain_id -> fail (not_comparable "chain_id")
+    | TC_unit -> fail (not_comparable "unit")
+    | TC_void -> fail (not_comparable "void")
+    | TC_bool -> fail (not_comparable "bool")
+    | TC_nat -> return nat_k
+    | TC_mutez -> return tez_k
+    | TC_int -> return int_k
+    | TC_string -> return string_k
+    | TC_address -> return address_k
+    | TC_timestamp -> return timestamp_k
+    | TC_bytes -> return bytes_k
+    | TC_operation -> fail (not_comparable "operation")
+    | TC_signature -> fail (not_comparable "signature")
+    | TC_key -> fail (not_comparable "key")
+    | TC_key_hash -> fail (not_comparable "key_hash")
+    | TC_chain_id -> fail (not_comparable "chain_id")
 
   let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
     match tv with
@@ -89,24 +89,24 @@ module Ty = struct
     | T_option _ -> fail (not_comparable "option")
     | T_contract _ -> fail (not_comparable "contract")
 
-  let base_type : type_base -> ex_ty result = fun b ->
+  let base_type : type_constant -> ex_ty result = fun b ->
     let return x = ok @@ Ex_ty x in
    match b with
-    | Base_unit -> return unit
-    | Base_void -> fail (not_compilable_type "void")
-    | Base_bool -> return bool
-    | Base_int -> return int
-    | Base_nat -> return nat
-    | Base_mutez -> return tez
-    | Base_string -> return string
-    | Base_address -> return address
-    | Base_timestamp -> return timestamp
-    | Base_bytes -> return bytes
-    | Base_operation -> return operation
-    | Base_signature -> return signature
-    | Base_key -> return key
-    | Base_key_hash -> return key_hash
-    | Base_chain_id -> return chain_id
+    | TC_unit -> return unit
+    | TC_void -> fail (not_compilable_type "void")
+    | TC_bool -> return bool
+    | TC_int -> return int
+    | TC_nat -> return nat
+    | TC_mutez -> return tez
+    | TC_string -> return string
+    | TC_address -> return address
+    | TC_timestamp -> return timestamp
+    | TC_bytes -> return bytes
+    | TC_operation -> return operation
+    | TC_signature -> return signature
+    | TC_key -> return key
+    | TC_key_hash -> return key_hash
+    | TC_chain_id -> return chain_id
 
   let rec type_ : type_value -> ex_ty result =
     function
@@ -175,23 +175,23 @@ module Ty = struct
 end
 
 
-let base_type : type_base -> O.michelson result =
+let base_type : type_constant -> O.michelson result =
   function
-  | Base_unit -> ok @@ O.prim T_unit
-  | Base_void -> fail (Ty.not_compilable_type "void")
-  | Base_bool -> ok @@ O.prim T_bool
-  | Base_int -> ok @@ O.prim T_int
-  | Base_nat -> ok @@ O.prim T_nat
-  | Base_mutez -> ok @@ O.prim T_mutez
-  | Base_string -> ok @@ O.prim T_string
-  | Base_address -> ok @@ O.prim T_address
-  | Base_timestamp -> ok @@ O.prim T_timestamp
-  | Base_bytes -> ok @@ O.prim T_bytes
-  | Base_operation -> ok @@ O.prim T_operation
-  | Base_signature -> ok @@ O.prim T_signature
-  | Base_key -> ok @@ O.prim T_key
-  | Base_key_hash -> ok @@ O.prim T_key_hash
-  | Base_chain_id -> ok @@ O.prim T_chain_id
+  | TC_unit -> ok @@ O.prim T_unit
+  | TC_void -> fail (Ty.not_compilable_type "void")
+  | TC_bool -> ok @@ O.prim T_bool
+  | TC_int -> ok @@ O.prim T_int
+  | TC_nat -> ok @@ O.prim T_nat
+  | TC_mutez -> ok @@ O.prim T_mutez
+  | TC_string -> ok @@ O.prim T_string
+  | TC_address -> ok @@ O.prim T_address
+  | TC_timestamp -> ok @@ O.prim T_timestamp
+  | TC_bytes -> ok @@ O.prim T_bytes
+  | TC_operation -> ok @@ O.prim T_operation
+  | TC_signature -> ok @@ O.prim T_signature
+  | TC_key -> ok @@ O.prim T_key
+  | TC_key_hash -> ok @@ O.prim T_key_hash
+  | TC_chain_id -> ok @@ O.prim T_chain_id
 
 let rec type_ : type_value -> O.michelson result =
   function

src/passes/operators/helpers.ml

@@ -14,17 +14,17 @@ module Typer = struct
       let title () = "these types are not comparable" in
       let message () = "" in
       let data = [
-        ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
-        ("b" , fun () -> Format.asprintf "%a" PP.type_value b )
+        ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
+        ("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
       ] in
       error ~data title message ()
   end
   open Errors
 
-  type type_result = type_value
-  type typer = type_value list -> type_value option -> type_result result
+  type type_result = type_expression
+  type typer = type_expression list -> type_expression option -> type_result result
 
-  let typer_0 : string -> (type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
+  let typer_0 : string -> (type_expression option -> type_expression result) -> typer = fun s f lst tv_opt ->
     match lst with
     | [] -> (
       let%bind tv' = f tv_opt in
@@ -32,7 +32,7 @@ module Typer = struct
     )
     | _ -> fail @@ wrong_param_number s 0 lst
 
-  let typer_1 : string -> (type_value -> type_value result) -> typer = fun s f lst _ ->
+  let typer_1 : string -> (type_expression -> type_expression result) -> typer = fun s f lst _ ->
     match lst with
     | [ a ] -> (
         let%bind tv' = f a in
@@ -40,7 +40,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 1 lst
 
-  let typer_1_opt : string -> (type_value -> type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
+  let typer_1_opt : string -> (type_expression -> type_expression option -> type_expression result) -> typer = fun s f lst tv_opt ->
     match lst with
     | [ a ] -> (
         let%bind tv' = f a tv_opt in
@@ -48,7 +48,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 1 lst
 
-  let typer_2 : string -> (type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
+  let typer_2 : string -> (type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
     match lst with
     | [ a ; b ] -> (
         let%bind tv' = f a b in
@@ -56,7 +56,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 2 lst
 
-  let typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
+  let typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> type_expression result) -> typer = fun s f lst tv_opt ->
     match lst with
     | [ a ; b ] -> (
         let%bind tv' = f a b tv_opt in
@@ -64,7 +64,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 2 lst
 
-  let typer_3 : string -> (type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
+  let typer_3 : string -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
     match lst with
     | [ a ; b ; c ] -> (
         let%bind tv' = f a b c in
@@ -72,7 +72,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 3 lst
 
-  let typer_4 : string -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
+  let typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
     match lst with
     | [ a ; b ; c ; d ] -> (
         let%bind tv' = f a b c d in
@@ -80,7 +80,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 4 lst
 
-  let typer_5 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
+  let typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
     match lst with
     | [ a ; b ; c ; d ; e ] -> (
         let%bind tv' = f a b c d e in
@@ -88,7 +88,7 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 5 lst
 
-  let typer_6 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
+  let typer_6 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
     match lst with
     | [ a ; b ; c ; d ; e ; f_ ] -> (
         let%bind tv' = f a b c d e f_ in
@@ -96,12 +96,12 @@ module Typer = struct
       )
     | _ -> fail @@ wrong_param_number s 6 lst
 
-  let constant name cst = typer_0 name (fun _ -> ok cst)
+  let constant' name cst = typer_0 name (fun _ -> ok cst)
 
   open Combinators
 
-  let eq_1 a cst = type_value_eq (a , cst)
-  let eq_2 (a , b) cst = type_value_eq (a , cst) && type_value_eq (b , cst)
+  let eq_1 a cst = type_expression_eq (a , cst)
+  let eq_2 (a , b) cst = type_expression_eq (a , cst) && type_expression_eq (b , cst)
 
   let assert_eq_1 ?msg a b = Assert.assert_true ?msg (eq_1 a b)
 
@@ -125,11 +125,11 @@ module Typer = struct
     let%bind () =
       trace_strong (simple_error "A isn't of type bool") @@
       Assert.assert_true @@
-      type_value_eq (t_bool () , a) in
+      type_expression_eq (t_bool () , a) in
     let%bind () =
       trace_strong (simple_error "B isn't of type bool") @@
       Assert.assert_true @@
-      type_value_eq (t_bool () , b) in
+      type_expression_eq (t_bool () , b) in
     ok @@ t_bool ()
 
 end

src/passes/operators/helpers.mli

@@ -4,51 +4,51 @@ module Typer : sig
 
   module Errors : sig
     val wrong_param_number : string -> int -> 'a list -> unit -> error
-    val error_uncomparable_types : type_value -> type_value -> unit -> error
+    val error_uncomparable_types : type_expression -> type_expression -> unit -> error
   end
 
-  type type_result = type_value
-  type typer = type_value list -> type_value option -> type_result result
+  type type_result = type_expression
+  type typer = type_expression list -> type_expression option -> type_result result
 
   (*
-  val typer'_0 : name -> (type_value option -> type_value result) -> typer'
+  val typer'_0 : name -> (type_expression option -> type_expression result) -> typer'
   *)
-  val typer_0 : string -> ( type_value option -> type_value result ) -> typer
+  val typer_0 : string -> ( type_expression option -> type_expression result ) -> typer
   (*
-  val typer'_1 : name -> (type_value -> type_value result) -> typer'
+  val typer'_1 : name -> (type_expression -> type_expression result) -> typer'
   *)
-  val typer_1 : string -> (type_value -> type_value result) -> typer
+  val typer_1 : string -> (type_expression -> type_expression result) -> typer
   (*
-  val typer'_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer'
+  val typer'_1_opt : name -> (type_expression -> type_expression option -> type_expression result) -> typer'
   *)
-  val typer_1_opt : string -> (type_value -> type_value option -> type_value result) -> typer
+  val typer_1_opt : string -> (type_expression -> type_expression option -> type_expression result) -> typer
   (*
-  val typer'_2 : name -> (type_value -> type_value -> type_value result) -> typer'
+  val typer'_2 : name -> (type_expression -> type_expression -> type_expression result) -> typer'
   *)
-  val typer_2 : string -> (type_value -> type_value -> type_value result) -> typer
-  val typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value result) -> typer
+  val typer_2 : string -> (type_expression -> type_expression -> type_expression result) -> typer
+  val typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> type_expression result) -> typer
   (*
-  val typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer'
+  val typer'_3 : name -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
   *)
-  val typer_3 : string -> (type_value -> type_value -> type_value -> type_value result) -> typer
+  val typer_3 : string -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer
   (*
-  val typer'_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
+  val typer'_4 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
   *)
-  val typer_4 : string -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
+  val typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer
   (*
-  val typer'_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
+  val typer'_5 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
   *)
-  val typer_5 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
+  val typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer
   (*
-  val typer'_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
+  val typer'_6 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
   *)
-  val typer_6 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
+  val typer_6 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer
 
-  val constant : string -> type_value -> typer 
+  val constant' : string -> type_expression -> typer 
 
-  val eq_1 : type_value -> type_value -> bool
-  val eq_2 : ( type_value * type_value ) -> type_value -> bool
-  val assert_eq_1 : ?msg:string -> type_value -> type_value -> unit result
+  val eq_1 : type_expression -> type_expression -> bool
+  val eq_2 : ( type_expression * type_expression ) -> type_expression -> bool
+  val assert_eq_1 : ?msg:string -> type_expression -> type_expression -> unit result
 
   val comparator : string -> typer
   val boolean_operator_2 : string -> typer

src/passes/operators/operators.ml

@@ -272,8 +272,8 @@ module Typer = struct
     let type_error msg expected_type actual_type () =
       let message () =
         Format.asprintf "Expected an expression of type %a but got an expression of type %a"
-          Ast_typed.PP.type_value expected_type
-          Ast_typed.PP.type_value actual_type in
+          Ast_typed.PP.type_expression expected_type
+          Ast_typed.PP.type_expression actual_type in
       error (thunk msg) message
 
     open PP_helpers
@@ -285,8 +285,8 @@ module Typer = struct
     let typeclass_error msg f expected_types actual_types () =
       let message () =
         Format.asprintf "Expected arguments with one of the following combinations of types: %a but got this combination instead: %a"
-          (list_sep (print_f_args f Ast_typed.PP.type_value) (const " or ")) expected_types
-          (print_f_args f Ast_typed.PP.type_value) actual_types in
+          (list_sep (print_f_args f Ast_typed.PP.type_expression) (const " or ")) expected_types
+          (print_f_args f Ast_typed.PP.type_expression) actual_types in
       error (thunk msg) message
   end
   (*
@@ -328,6 +328,7 @@ module Typer = struct
     let tc_addargs  a b c = tc [a;b;c] [ (*TODO…*) ]
 
     let t_none         = forall "a" @@ fun a -> option a
+
     let t_sub          = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => tuple2 a b --> c (* TYPECLASS *)
     let t_some         = forall "a" @@ fun a -> a --> option a
     let t_map_remove   = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst
@@ -375,7 +376,7 @@ module Typer = struct
     let t_set_remove   = forall "a" @@ fun a -> tuple2 a (set a) --> set a
     let t_not          = tuple1 bool --> bool
 
-    let constant_type : constant -> Typesystem.Core.type_value result = function
+    let constant_type : constant' -> Typesystem.Core.type_value result = function
       | C_INT                 -> ok @@ t_int ;
       | C_UNIT                -> ok @@ t_unit ;
       | C_NOW                 -> ok @@ t_now ;
@@ -489,42 +490,42 @@ module Typer = struct
 
   let list_cons : typer = typer_2 "CONS" @@ fun hd tl ->
     let%bind tl' = get_t_list tl in
-    let%bind () = assert_type_value_eq (hd , tl') in
+    let%bind () = assert_type_expression_eq (hd , tl') in
     ok tl
 
   let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m ->
     let%bind (src , _) = bind_map_or (get_t_map , get_t_big_map) m in
-    let%bind () = assert_type_value_eq (src , k) in
+    let%bind () = assert_type_expression_eq (src , k) in
     ok m
 
   let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
     let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
-    let%bind () = assert_type_value_eq (src, k) in
-    let%bind () = assert_type_value_eq (dst, v) in
+    let%bind () = assert_type_expression_eq (src, k) in
+    let%bind () = assert_type_expression_eq (dst, v) in
     ok m
 
   let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m ->
     let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
-    let%bind () = assert_type_value_eq (src, k) in
+    let%bind () = assert_type_expression_eq (src, k) in
     let%bind v' = get_t_option v in
-    let%bind () = assert_type_value_eq (dst, v') in
+    let%bind () = assert_type_expression_eq (dst, v') in
     ok m
 
   let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m ->
     let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in
-    let%bind () = assert_type_value_eq (src, k) in
+    let%bind () = assert_type_expression_eq (src, k) in
     ok @@ t_bool ()
 
   let map_find : typer = typer_2 "MAP_FIND" @@ fun k m ->
     let%bind (src, dst) =
       trace_strong (simple_error "MAP_FIND: not map or bigmap") @@
       bind_map_or (get_t_map , get_t_big_map) m in
-    let%bind () = assert_type_value_eq (src, k) in
+    let%bind () = assert_type_expression_eq (src, k) in
     ok @@ dst
 
   let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m ->
     let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
-    let%bind () = assert_type_value_eq (src, k) in
+    let%bind () = assert_type_expression_eq (src, k) in
     ok @@ t_option dst ()
 
   let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m ->
@@ -601,17 +602,17 @@ module Typer = struct
     let%bind () = assert_t_bytes b in
     ok @@ t_bool ()
 
-  let sender = constant "SENDER" @@ t_address ()
+  let sender = constant' "SENDER" @@ t_address ()
 
-  let source = constant "SOURCE" @@ t_address ()
+  let source = constant' "SOURCE" @@ t_address ()
 
-  let unit = constant "UNIT" @@ t_unit ()
+  let unit = constant' "UNIT" @@ t_unit ()
 
-  let amount = constant "AMOUNT" @@ t_mutez ()
+  let amount = constant' "AMOUNT" @@ t_mutez ()
 
-  let balance = constant "BALANCE" @@ t_mutez ()
+  let balance = constant' "BALANCE" @@ t_mutez ()
 
-  let chain_id = constant "CHAIN_ID" @@ t_chain_id ()
+  let chain_id = constant' "CHAIN_ID" @@ t_chain_id ()
 
   let address = typer_1 "ADDRESS" @@ fun contract ->
     let%bind () = assert_t_contract contract in
@@ -624,12 +625,12 @@ module Typer = struct
     let%bind () = assert_t_key_hash key_hash in
     ok @@ t_contract (t_unit () ) ()
 
-  let now = constant "NOW" @@ t_timestamp ()
+  let now = constant' "NOW" @@ t_timestamp ()
 
   let transaction = typer_3 "CALL" @@ fun param amount contract ->
     let%bind () = assert_t_mutez amount in
     let%bind contract_param = get_t_contract contract in
-    let%bind () = assert_type_value_eq (param , contract_param) in
+    let%bind () = assert_type_expression_eq (param , contract_param) in
     ok @@ t_operation ()
 
   let originate = typer_6 "ORIGINATE" @@ fun manager delegate_opt spendable delegatable init_balance code ->
@@ -646,8 +647,8 @@ module Typer = struct
     ok @@ (t_pair (t_operation ()) (t_address ()) ())
 
   let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt ->
-    if not (type_value_eq (addr_tv, t_address ()))
-    then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_value addr_tv)
+    if not (type_expression_eq (addr_tv, t_address ()))
+    then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_expression addr_tv)
     else
     let%bind tv =
       trace_option (simple_error "get_contract needs a type annotation") tv_opt in
@@ -657,8 +658,8 @@ module Typer = struct
     ok @@ t_contract tv' ()
 
   let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt ->
-    if not (type_value_eq (addr_tv, t_address ()))
-    then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_value addr_tv)
+    if not (type_expression_eq (addr_tv, t_address ()))
+    then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_expression addr_tv)
     else
     let%bind tv =
       trace_option (simple_error "get_contract_opt needs a type annotation") tv_opt in
@@ -671,11 +672,11 @@ module Typer = struct
     ok @@ t_option (t_contract tv' ()) ()
 
   let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt ->
-    if not (type_value_eq (entry_tv, t_string ()))
-    then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_value entry_tv)
+    if not (type_expression_eq (entry_tv, t_string ()))
+    then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv)
     else
-    if not (type_value_eq (addr_tv, t_address ()))
-    then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_value addr_tv)
+    if not (type_expression_eq (addr_tv, t_address ()))
+    then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_expression addr_tv)
     else
     let%bind tv =
       trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in
@@ -685,11 +686,11 @@ module Typer = struct
     ok @@ t_contract tv' ()
 
   let get_entrypoint_opt = typer_2_opt "CONTRACT_ENTRYPOINT_OPT" @@ fun entry_tv addr_tv tv_opt ->
-    if not (type_value_eq (entry_tv, t_string ()))
-    then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects a string entrypoint label for first argument, got %a" PP.type_value entry_tv)
+    if not (type_expression_eq (entry_tv, t_string ()))
+    then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv)
     else
-    if not (type_value_eq (addr_tv, t_address ()))
-    then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_value addr_tv)
+    if not (type_expression_eq (addr_tv, t_address ()))
+    then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_expression addr_tv)
     else
     let%bind tv =
       trace_option (simple_error "get_entrypoint_opt needs a type annotation") tv_opt in
@@ -840,8 +841,8 @@ module Typer = struct
     let%bind (prec , cur) = get_t_pair arg in
     let%bind key = get_t_list lst in
     let msg = Format.asprintf "%a vs %a"
-        Ast_typed.PP.type_value key
-        Ast_typed.PP.type_value arg
+        PP.type_expression key
+        PP.type_expression arg
     in
     trace (simple_error ("bad list fold:" ^ msg)) @@
     let%bind () = assert_eq_1 ~msg:"key cur" key cur in
@@ -854,8 +855,8 @@ module Typer = struct
     let%bind (prec , cur) = get_t_pair arg in
     let%bind key = get_t_set lst in
     let msg = Format.asprintf "%a vs %a"
-        Ast_typed.PP.type_value key
-        Ast_typed.PP.type_value arg
+        PP.type_expression key
+        PP.type_expression arg
     in
     trace (simple_error ("bad set fold:" ^ msg)) @@
     let%bind () = assert_eq_1 ~msg:"key cur" key cur in
@@ -868,10 +869,10 @@ module Typer = struct
     let%bind (prec , cur) = get_t_pair arg in
     let%bind (key , value) = get_t_map map in
     let msg = Format.asprintf "%a vs %a"
-        Ast_typed.PP.type_value key
-        Ast_typed.PP.type_value arg
+        PP.type_expression key
+        PP.type_expression arg
     in
-    trace (simple_error ("bad list fold:" ^ msg)) @@
+    trace (simple_error ("bad map fold:" ^ msg)) @@
     let%bind () = assert_eq_1 ~msg:"key cur" (t_pair key value ()) cur in
     let%bind () = assert_eq_1 ~msg:"prec res" prec res in
     let%bind () = assert_eq_1 ~msg:"res init" res init in
@@ -1062,7 +1063,7 @@ module Typer = struct
     | C_SELF_ADDRESS        -> ok @@ self_address;
     | C_IMPLICIT_ACCOUNT    -> ok @@ implicit_account;
     | C_SET_DELEGATE        -> ok @@ set_delegate ;
-    | _                     -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" Stage_common.PP.constant c
+    | _                     -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" PP.constant c
 
 
 
@@ -1151,7 +1152,8 @@ module Compiler = struct
     | C_BYTES_PACK      -> ok @@ simple_unary @@ prim I_PACK
     | C_CONCAT          -> ok @@ simple_binary @@ prim I_CONCAT
     | C_CHAIN_ID        -> ok @@ simple_constant @@ prim I_CHAIN_ID
-    | _                 -> simple_fail @@ Format.asprintf "operator not implemented for %a" Stage_common.PP.constant c
+    | _                 -> simple_fail @@ Format.asprintf "operator not implemented for %a" PP.constant c
+
   
 
   (*

src/passes/operators/operators.mli

@@ -4,16 +4,15 @@ module Simplify : sig
  open Trace
 
   module Pascaligo : sig
-    val constants  : string -> constant result
+    val constants  : string -> constant' result
     val type_constants : string -> type_constant result
-    val type_operators : string -> type_expression type_operator result
+    val type_operators : string -> type_operator result
   end
 
-
   module Cameligo : sig
-    val constants  : string -> constant result
+    val constants  : string -> constant' result
     val type_constants : string -> type_constant result
-    val type_operators : string -> type_expression type_operator result
+    val type_operators : string -> type_operator result
   end
 
 end
@@ -94,7 +93,7 @@ module Typer : sig
       val t_set_add : Typesystem.Core.type_value
       val t_set_remove : Typesystem.Core.type_value
       val t_not : Typesystem.Core.type_value
-      val constant_type : constant -> Typesystem.Core.type_value Trace.result
+      val constant_type : constant' -> Typesystem.Core.type_value Trace.result
     end
 
   (*
@@ -171,7 +170,7 @@ module Typer : sig
   val concat : typer
   *)
   val cons : typer
-  val constant_typers : constant -> typer result
+  val constant_typers : constant' -> typer result
 
 end
 
@@ -191,7 +190,7 @@ module Compiler : sig
     | Tetrary of michelson
     | Pentary of michelson
     | Hexary of michelson
-  val get_operators : constant -> predicate result
+  val get_operators : constant' -> predicate result
   val simple_constant : t -> predicate
   val simple_unary : t -> predicate
   val simple_binary : t -> predicate

src/stages/ast_simplified/PP.ml

@@ -1,110 +1,93 @@
 [@@@coverage exclude_file]
 open Types
-open PP_helpers
 open Format
+open PP_helpers
+
 include Stage_common.PP
+include Ast_PP_type(Ast_simplified_parameter)
 
-let list_sep_d x ppf lst = match lst with
-  | [] -> ()
-  | _ -> fprintf ppf " @[<v>%a@] " (list_sep x (tag " ; ")) lst
-let tuple_sep_d x ppf lst = match lst with
-  | [] -> ()
-  | _ -> fprintf ppf " @[<v>%a@] " (list_sep x (tag " , ")) lst
+let expression_variable ppf (ev : expression_variable) : unit =
+  fprintf ppf "%a" Var.pp ev
 
-let rec te' ppf (te : type_expression type_expression') : unit =
-  type_expression' type_expression ppf te
 
-and type_expression ppf (te: type_expression) : unit =
-  te' ppf te.type_expression'
+let rec expression ppf (e : expression) =
+  match e.expression_content with
+  | E_literal l ->
+      literal ppf l
+  | E_variable n ->
+      fprintf ppf "%a" expression_variable n
+  | E_application app ->
+      fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2
+  | E_constructor c ->
+      fprintf ppf "%a(%a)" constructor c.constructor expression c.element
+  | E_constant c ->
+      fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
+        c.arguments
+  | E_record m ->
+      fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
+  | E_record_accessor ra ->
+      fprintf ppf "%a.%a" expression ra.expr label ra.label
+  | E_record_update {record; path; update} ->
+      fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
+  | E_map m ->
+      fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
+  | E_big_map m ->
+      fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
+  | E_list lst ->
+      fprintf ppf "list[%a]" (list_sep_d expression) lst
+  | E_set lst ->
+      fprintf ppf "set[%a]" (list_sep_d expression) lst
+  | E_look_up (ds, ind) ->
+      fprintf ppf "(%a)[%a]" expression ds expression ind
+  | E_lambda {binder; input_type; output_type; result} ->
+      fprintf ppf "lambda (%a:%a) : %a return %a" option_type_name binder
+        (PP_helpers.option type_expression)
+        input_type
+        (PP_helpers.option type_expression)
+        output_type expression result
+  | E_matching {matchee; cases; _} ->
+      fprintf ppf "match %a with %a" expression matchee (matching expression)
+        cases
+  | E_loop l ->
+      fprintf ppf "while %a do %a" expression l.condition expression l.body
+  | E_let_in { let_binder ; mut; rhs ; let_result; inline } ->    
+    fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
+  | E_skip ->
+      fprintf ppf "skip"
+  | E_ascription {anno_expr; type_annotation} ->
+      fprintf ppf "%a : %a" expression anno_expr type_expression
+        type_annotation
 
-let rec expression ppf (e:expression) = match e.expression with
-  | E_literal l -> fprintf ppf "%a" literal l
-  | E_variable n -> fprintf ppf "%a" name n
-  | E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg
-  | E_constructor (c, ae) -> fprintf ppf "%a(%a)" constructor c expression ae
-  | E_constant (b, lst) -> fprintf ppf "%a(%a)" constant b (list_sep_d expression) lst
-  | E_tuple lst -> fprintf ppf "(%a)" (tuple_sep_d expression) lst
-  | E_accessor (ae, p) -> fprintf ppf "%a.%a" expression ae access_path p
-  | E_record m -> fprintf ppf "{%a}" (lrecord_sep expression (const " , ")) m
-  | E_update {record; update=(path,expr)} -> fprintf ppf "%a with { %a = %a }" expression record Stage_common.PP.label path expression expr
-  | E_map m -> fprintf ppf "[%a]" (list_sep_d assoc_expression) m
-  | E_big_map m -> fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
-  | E_list lst -> fprintf ppf "[%a]" (list_sep_d expression) lst
-  | E_set lst  -> fprintf ppf "{%a}" (list_sep_d expression) lst
-  | E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" expression ds expression ind
-  | E_lambda {binder;input_type;output_type;result} ->
-      fprintf ppf "lambda (%a:%a) : %a return %a"
-        option_type_name binder
-        (PP_helpers.option type_expression) input_type (PP_helpers.option type_expression) output_type
-        expression result
-  | E_matching (ae, m) ->
-      fprintf ppf "match %a with %a" expression ae (matching expression) m
-  | E_sequence (a , b) ->
-    fprintf ppf "%a ; %a"
-      expression a
-      expression b
-  | E_loop (expr , body) ->
-    fprintf ppf "%a ; %a"
-      expression expr
-      expression body
-  | E_assign (n , path , expr) ->
-    fprintf ppf "%a.%a := %a"
-      name n
-      PP_helpers.(list_sep access (const ".")) path
-      expression expr
-  | E_let_in { binder ; rhs ; result; inline } ->    
-    fprintf ppf "let %a = %a%a in %a" option_type_name binder expression rhs option_inline inline expression result
-  | E_skip -> fprintf ppf "skip"
-  | E_ascription (expr , ty) -> fprintf ppf "%a : %a" expression expr type_expression ty
-
-and option_type_name ppf ((n , ty_opt) : expression_variable * type_expression option) =
+and option_type_name ppf
+    ((n, ty_opt) : expression_variable * type_expression option) =
   match ty_opt with
-  | None -> fprintf ppf "%a" name n
-  | Some ty -> fprintf ppf "%a : %a" name n type_expression ty
+  | None ->
+      fprintf ppf "%a" expression_variable n
+  | Some ty ->
+      fprintf ppf "%a : %a" expression_variable n type_expression ty
 
-and option_inline ppf inline = 
-  if inline then 
-    fprintf ppf "[@inline]"
-  else
-    fprintf ppf ""
+and assoc_expression ppf : expr * expr -> unit =
+ fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
 
-and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) ->
-  fprintf ppf "%a -> %a" expression a expression b
+and single_record_patch ppf ((p, expr) : label * expr) =
+  fprintf ppf "%a <- %a" label p expression expr
 
-and access ppf (a:access) =
-  match a with
-  | Access_tuple i -> fprintf ppf "%d" i
-  | Access_record l -> fprintf ppf "%s" l
-
-and access_path ppf (p:access_path) =
-  fprintf ppf "%a" (list_sep access (const ".")) p
-
-and type_annotation ppf (ta:type_expression option) = match ta with
-  | None -> fprintf ppf ""
-  | Some t -> type_expression ppf t
-
-and single_record_patch ppf ((p, expr) : string * expr) =
-  fprintf ppf "%s <- %a" p expression expr
-
-and single_tuple_patch ppf ((p, expr) : int * expr) =
-  fprintf ppf "%d <- %a" p expression expr
-
-and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor * expression_variable) * a -> unit =
+and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
   fun f ppf ((c,n),a) ->
-  fprintf ppf "| %a %a -> %a" constructor c name n f a
+  fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
 
-and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching -> unit =
+and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
   fun f ppf m -> match m with
     | Match_tuple ((lst, b), _) ->
-        fprintf ppf "let (%a) = %a" (list_sep_d name) lst f b
+        fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
     | Match_variant (lst, _) ->
         fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
     | Match_bool {match_true ; match_false} ->
         fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
     | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
-        fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil name hd name tl f match_cons
+        fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
     | Match_option {match_none ; match_some = (some, match_some, _)} ->
-        fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
+        fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
 
 (* Shows the type expected for the matched value *)
 and matching_type ppf m = match m with
@@ -120,13 +103,30 @@ and matching_type ppf m = match m with
       fprintf ppf "option"
 
 and matching_variant_case_type ppf ((c,n),_a) =
-  fprintf ppf "| %a %a" constructor c name n
+  fprintf ppf "| %a %a" constructor c expression_variable n
 
-let declaration ppf (d:declaration) = match d with
-  | Declaration_type (type_name , te) ->
-      fprintf ppf "type %a = %a" type_variable (type_name) type_expression te
-  | Declaration_constant (name , ty_opt , inline, expr) ->            
-      fprintf ppf "const %a = %a%a" option_type_name (name , ty_opt) expression expr option_inline inline
+and option_mut ppf mut = 
+  if mut then 
+    fprintf ppf "[@mut]"
+  else
+    fprintf ppf ""
 
-let program ppf (p:program) =
-  fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)
+and option_inline ppf inline = 
+  if inline then 
+    fprintf ppf "[@inline]"
+  else
+    fprintf ppf ""
+
+let declaration ppf (d : declaration) =
+  match d with
+  | Declaration_type (type_name, te) ->
+      fprintf ppf "type %a = %a" type_variable type_name type_expression te
+  | Declaration_constant (name, ty_opt, i, expr) ->
+      fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression
+        expr
+        option_inline i
+
+let program ppf (p : program) =
+  fprintf ppf "@[<v>%a@]"
+    (list_sep declaration (tag "@;"))
+    (List.map Location.unwrap p)

src/stages/ast_simplified/PP.mli

@@ -1,47 +0,0 @@
-(** Pretty printer for the Simplified Abstract Syntax Tree *)
-
-open Types
-open Format
-
-(*
-val list_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
-
-val smap_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a Map.String.t -> unit
-
-*)
-val type_expression : formatter -> type_expression -> unit
-
-val literal : formatter -> literal -> unit
-
-val expression : formatter -> expression -> unit
-(*
-val option_type_name : formatter -> string * type_expression option -> unit
-val assoc_expression : formatter -> (expr * expr) -> unit
-
-val access : formatter -> access -> unit
-
-val access_path : formatter -> access_path -> unit
-*)
-
-val type_annotation : formatter -> type_expression option -> unit 
-val single_record_patch : formatter -> string * expr -> unit 
-
-val single_tuple_patch : formatter -> int * expr -> unit
-(*
-
-val matching_variant_case : (formatter -> 'a -> unit) -> formatter -> (constructor_name * name) * 'a -> unit
-
-val matching : (formatter -> 'a -> unit) -> formatter -> 'a matching -> unit
-*)
-
-(** Shows the type expected for the matched value *)
-val matching_type : formatter -> ('a, 'var) matching -> unit
-
-(*
-val matching_variant_case_type : formatter -> ( ( constructor_name * name) * 'a) -> unit
-
-val declaration : formatter -> declaration -> unit
-
-*)
-(** Pretty print a full program AST *)
-val program : formatter -> program -> unit

src/stages/ast_simplified/ast_simplified.ml

@@ -1,8 +1,8 @@
 include Types
+
 (* include Misc *)
 include Combinators
-
 module Types = Types
 module Misc = Misc
-module PP = PP
+module PP=PP
 module Combinators = Combinators

src/stages/ast_simplified/combinators.ml

@@ -13,13 +13,19 @@ module Errors = struct
     ] in
     error ~data title message
   let bad_type_operator type_op =
-    let title () = Format.asprintf "bad type operator %a" (Stage_common.PP.type_operator PP.type_expression) type_op in
+    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
 
-let make_t type_expression' = {type_expression'}
+let make_t type_content = {type_content; type_meta = ()}
+
+  
+let tuple_to_record lst =
+  let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in
+  let (_, lst ) = List.fold_left aux (0,[]) lst in
+  lst
 
 let t_bool         : type_expression = make_t @@ T_constant (TC_bool)
 let t_string       : type_expression = make_t @@ T_constant (TC_string)
@@ -36,8 +42,6 @@ let t_key_hash     : type_expression = make_t @@ T_constant (TC_key_hash)
 let t_option  o    : type_expression = make_t @@ T_operator (TC_option o)
 let t_list  t      : type_expression = make_t @@ T_operator (TC_list t)
 let t_variable n   : type_expression = make_t @@ T_variable (Var.of_name n)
-let t_tuple lst    : type_expression = make_t @@ T_operator (TC_tuple lst)
-let t_pair (a , b) : type_expression = t_tuple [a ; b]
 let t_record_ez lst =
   let lst = List.map (fun (k, v) -> (Label k, v)) lst in
   let m = LMap.of_list lst in
@@ -46,6 +50,9 @@ let t_record m  : type_expression =
   let lst = Map.String.to_kv_list m in
   t_record_ez lst
 
+let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)]
+let t_tuple lst    : type_expression = t_record_ez (tuple_to_record lst)
+
 let ez_t_sum (lst:(string * type_expression) list) : type_expression =
   let aux prev (k, v) = CMap.add (Constructor k) v prev in
   let map = List.fold_left aux CMap.empty lst in
@@ -54,7 +61,7 @@ let t_sum m : type_expression =
   let lst = Map.String.to_kv_list m in
   ez_t_sum lst
 
-let t_function param result : type_expression = make_t @@ T_arrow (param, result)
+let t_function type1 type2  : type_expression = make_t @@ T_arrow {type1; type2}
 let t_map key value         : type_expression = make_t @@ T_operator (TC_map (key, value))
 let t_big_map key value     : type_expression = make_t @@ T_operator (TC_big_map (key , value))
 let t_set key               : type_expression = make_t @@ T_operator (TC_set key)
@@ -71,9 +78,9 @@ let t_operator op lst: type_expression result =
   | TC_contract _    , [t] -> ok @@ t_contract t
   | _ , _ -> fail @@ bad_type_operator op
 
-let location_wrap ?(loc = Location.generated) expression =
+let location_wrap ?(loc = Location.generated) expression_content =
   let location = loc in
-  { location ; expression }
+  { expression_content; location }
 
 let e_var ?loc (n: string) : expression = location_wrap ?loc @@ E_variable (Var.of_name n)
 let e_literal ?loc l : expression = location_wrap ?loc @@ E_literal l
@@ -89,7 +96,7 @@ let e_signature ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_s
 let e_key ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key s)
 let e_key_hash ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key_hash s)
 let e_chain_id ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_chain_id s)
-let e'_bytes b : expression' result =
+let e'_bytes b : expression_content result =
   let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in
   ok @@ E_literal (Literal_bytes bytes)
 let e_bytes_hex ?loc b : expression result =
@@ -100,37 +107,51 @@ let e_bytes_raw ?loc (b: bytes) : expression =
 let e_bytes_string ?loc (s: string) : expression =
   location_wrap ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
 let e_big_map ?loc lst : expression = location_wrap ?loc @@ E_big_map lst
-let e_record ?loc map : expression = location_wrap ?loc @@ E_record map
-let e_tuple ?loc lst : expression = location_wrap ?loc @@ E_tuple lst
-let e_some ?loc s  : expression = location_wrap ?loc @@ E_constant (C_SOME, [s])
-let e_none ?loc () : expression = location_wrap ?loc @@ E_constant (C_NONE, [])
-let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant (C_CONCAT, [sl ; sr ])
-let e_map_add ?loc k v old  : expression = location_wrap ?loc @@ E_constant (C_MAP_ADD, [k ; v ; old])
+let e_some ?loc s  : expression = location_wrap ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
+let e_none ?loc () : expression = location_wrap ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
+let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
+let e_map_add ?loc k v old  : expression = location_wrap ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
 let e_map ?loc lst : expression = location_wrap ?loc @@ E_map lst
 let e_set ?loc lst : expression = location_wrap ?loc @@ E_set lst
 let e_list ?loc lst : expression = location_wrap ?loc @@ E_list lst
-let e_pair ?loc a b : expression = location_wrap ?loc @@ E_tuple [a; b]
-let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor (Constructor s , a)
-let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching (a , b)
+let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor { constructor = Constructor s; element = a}
+let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching {matchee=a;cases=b}
 let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
-let e_accessor ?loc a b = location_wrap ?loc @@ E_accessor (a , b)
-let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b)
+let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; label= Label b}
+let e_accessor_list ?loc a b  = List.fold_left (fun a b -> e_accessor ?loc a b) a b
 let e_variable ?loc v = location_wrap ?loc @@ E_variable v
 let e_skip ?loc () = location_wrap ?loc @@ E_skip
-let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body)
-let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b)
-let e_let_in ?loc (binder, ascr) inline rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result ; inline }
-let e_annotation ?loc expr ty = location_wrap ?loc @@ E_ascription (expr , ty)
-let e_application ?loc a b = location_wrap ?loc @@ E_application (a , b)
-let e_binop ?loc name a b  = location_wrap ?loc @@ E_constant (name , [a ; b])
-let e_constant ?loc name lst = location_wrap ?loc @@ E_constant (name , lst)
+let e_loop ?loc condition body = location_wrap ?loc @@ E_loop {condition; body}
+let e_let_in ?loc (binder, ascr) mut inline rhs let_result = 
+  location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
+let e_annotation ?loc anno_expr ty = location_wrap ?loc @@ E_ascription {anno_expr; type_annotation = ty}
+let e_application ?loc a b = location_wrap ?loc @@ E_application {expr1=a ; expr2=b}
+let e_binop ?loc name a b  = location_wrap ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
+let e_constant ?loc name lst = location_wrap ?loc @@ E_constant {cons_name=name ; arguments = lst}
 let e_look_up ?loc x y = location_wrap ?loc @@ E_look_up (x , y)
-let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c)
+let e_sequence ?loc expr1 expr2 = e_let_in ?loc (Var.fresh (), Some t_unit) false false expr1 expr2
+let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
+(*
+let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*)
+*)
 let ez_match_variant (lst : ((string * string) * 'a) list) =
   let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
   Match_variant (lst,())
 let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
   e_matching ?loc a (ez_match_variant lst)
+let e_record_ez ?loc (lst : (string * expr) list) : expression =
+  let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
+  location_wrap ?loc @@ E_record map
+let e_record ?loc map =
+  let lst = Map.String.to_kv_list map in
+  e_record_ez ?loc lst 
+
+let e_update ?loc record path update = 
+  let path = Label path in
+  location_wrap ?loc @@ E_record_update {record; path; update}
+
+let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
+let e_pair ?loc a b  : expression = e_tuple ?loc [a;b]
 
 let make_option_typed ?loc e t_opt =
   match t_opt with
@@ -138,12 +159,6 @@ let make_option_typed ?loc e t_opt =
   | Some t -> e_annotation ?loc e t
 
 
-let ez_e_record ?loc (lst : (string * expr) list) =
-  let aux prev (k, v) = LMap.add k v prev in
-  let lst = List.map (fun (k,v) -> (Label k, v)) lst in
-  let map = List.fold_left aux LMap.empty lst in
-  e_record ?loc map
-
 let e_typed_none ?loc t_opt =
   let type_annotation = t_option t_opt in
   e_annotation ?loc (e_none ?loc ()) type_annotation
@@ -156,6 +171,7 @@ let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map
 
 let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
 
+
 let e_lambda ?loc (binder : expression_variable)
     (input_type : type_expression option)
     (output_type : type_expression option)
@@ -168,34 +184,41 @@ let e_lambda ?loc (binder : expression_variable)
     result ;
   }
 
-let e_ez_record ?loc (lst : (string * expr) list) : expression =
-  let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
-  location_wrap ?loc @@ E_record map
-let e_record ?loc map =
-  let lst = Map.String.to_kv_list map in
-  e_ez_record ?loc lst 
 
-let e_update ?loc record path expr = 
-  let update = (Label path, expr) in
-  location_wrap ?loc @@ E_update {record; update}
+let e_assign_with_let ?loc var access_path expr = 
+  let var = Var.of_name (var) in
+  match access_path with 
+  | [] -> (var, None), true, expr, false
+
+  | lst -> 
+    let rec aux path record= match path with 
+    | [] -> failwith "acces_path cannot be empty"
+    | [e] -> e_update ?loc record e expr
+    | elem::tail -> 
+      let next_record = e_accessor record elem in
+      e_update ?loc record elem (aux tail next_record )
+    in 
+    (var, None), true, (aux lst (e_variable var)), false
 
 let get_e_accessor = fun t ->
   match t with
-  | E_accessor (a , b) -> ok (a , b)
+  | E_record_accessor {expr; label} -> ok (expr , label)
   | _ -> simple_fail "not an accessor"
 
 let assert_e_accessor = fun t ->
   let%bind _ = get_e_accessor t in
   ok ()
 
-let get_access_record : access -> string result = fun a ->
-  match a with
-  | Access_tuple _ -> simple_fail "not an access record"
-  | Access_record s -> ok s
-
 let get_e_pair = fun t ->
   match t with
-  | E_tuple [a ; b] -> ok (a , b)
+  | E_record r -> ( 
+  let lst = LMap.to_kv_list r in
+    match lst with 
+    | [(Label "O",a);(Label "1",b)]
+    | [(Label "1",b);(Label "0",a)] -> 
+        ok (a , b)
+    | _ -> simple_fail "not a pair"
+    )
   | _ -> simple_fail "not a pair"
 
 let get_e_list = fun t ->
@@ -203,27 +226,42 @@ let get_e_list = fun t ->
   | E_list lst -> ok lst
   | _ -> simple_fail "not a list"
 
+let tuple_of_record (m: _ LMap.t) =
+  let aux i = 
+    let opt = LMap.find_opt (Label (string_of_int i)) m in
+    Option.bind (fun opt -> Some (opt,i+1)) opt
+  in
+  Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
+
 let get_e_tuple = fun t ->
   match t with
-  | E_tuple lst -> ok lst
+  | E_record r -> ok @@ tuple_of_record r
   | _ -> simple_fail "ast_simplified: get_e_tuple: not a tuple"
 
+(* Same as get_e_pair *)
 let extract_pair : expression -> (expression * expression) result = fun e ->
-  match e.expression with
-  | E_tuple [ a ; b ] -> ok (a , b)
+  match e.expression_content with
+  | E_record r -> ( 
+  let lst = LMap.to_kv_list r in
+    match lst with 
+    | [(Label "O",a);(Label "1",b)]
+    | [(Label "1",b);(Label "0",a)] -> 
+        ok (a , b)
+    | _ -> fail @@ bad_kind "pair" e.location
+    )
   | _ -> fail @@ bad_kind "pair" e.location
 
 let extract_list : expression -> (expression list) result = fun e ->
-  match e.expression with
+  match e.expression_content with
   | E_list lst -> ok lst
   | _ -> fail @@ bad_kind "list" e.location
 
 let extract_record : expression -> (label * expression) list result = fun e ->
-  match e.expression with
+  match e.expression_content with
   | E_record lst -> ok @@ LMap.to_kv_list lst
   | _ -> fail @@ bad_kind "record" e.location
 
 let extract_map : expression -> (expression * expression) list result = fun e ->
-  match e.expression with
+  match e.expression_content with
   | E_map lst -> ok lst
   | _ -> fail @@ bad_kind "map" e.location

src/stages/ast_simplified/combinators.mli

@@ -9,7 +9,7 @@ module Errors : sig
   val bad_kind : name -> Location.t -> unit -> error
 end
 *)
-val make_t      : type_expression type_expression' -> type_expression
+val make_t      : type_content -> type_expression
 val t_bool      : type_expression
 val t_string    : type_expression
 val t_bytes     : type_expression
@@ -27,11 +27,11 @@ val t_option    : type_expression -> type_expression
 *)
 val t_list      : type_expression -> type_expression
 val t_variable  : string -> type_expression
-val t_tuple     : type_expression list -> type_expression
 (*
 val t_record    : te_map -> type_expression
 *)
 val t_pair : ( type_expression * type_expression ) -> type_expression
+val t_tuple     : type_expression list -> type_expression
 
 val t_record : type_expression Map.String.t -> type_expression
 val t_record_ez : (string * type_expression) list -> type_expression
@@ -42,7 +42,7 @@ val ez_t_sum : ( string * type_expression ) list -> type_expression
 val t_function : type_expression -> type_expression -> type_expression
 val t_map : type_expression -> type_expression -> type_expression
 
-val t_operator : type_expression type_operator -> type_expression list -> type_expression result
+val t_operator : type_operator -> type_expression list -> type_expression result
 val t_set : type_expression -> type_expression
 
 val e_var : ?loc:Location.t -> string -> expression
@@ -59,14 +59,13 @@ val e_key : ?loc:Location.t -> string -> expression
 val e_key_hash : ?loc:Location.t -> string -> expression 
 val e_chain_id : ?loc:Location.t -> string -> expression 
 val e_mutez : ?loc:Location.t -> int -> expression
-val e'_bytes : string -> expression' result
+val e'_bytes : string -> expression_content result
 val e_bytes_hex : ?loc:Location.t -> string -> expression result
 val e_bytes_raw : ?loc:Location.t -> bytes -> expression
 val e_bytes_string : ?loc:Location.t -> string -> expression
 val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
-(*
-val e_record  : ?loc:Location.t -> ( expr * expr ) list -> expression
-*)
+
+val e_record_ez  : ?loc:Location.t -> ( string * expr ) list -> expression
 val e_tuple : ?loc:Location.t -> expression list -> expression
 val e_some : ?loc:Location.t -> expression -> expression
 val e_none : ?loc:Location.t -> unit -> expression
@@ -79,24 +78,23 @@ val e_pair : ?loc:Location.t -> expression -> expression -> expression
 val e_constructor : ?loc:Location.t -> string -> expression -> expression
 val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
 val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
-val e_accessor : ?loc:Location.t -> expression -> access_path -> expression
-val e_accessor_props : ?loc:Location.t -> expression -> string list -> expression
+val e_accessor : ?loc:Location.t -> expression -> string -> expression
+val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
 val e_variable : ?loc:Location.t -> expression_variable -> expression
 val e_skip : ?loc:Location.t -> unit -> expression
 val e_loop : ?loc:Location.t -> expression -> expression -> expression
 val e_sequence : ?loc:Location.t -> expression -> expression -> expression
-val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> inline -> expression -> expression -> expression
+val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
+val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
 val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
 val e_application : ?loc:Location.t -> expression -> expression -> expression
-val e_binop    : ?loc:Location.t -> constant -> expression -> expression -> expression
-val e_constant : ?loc:Location.t -> constant -> expression list -> expression
+val e_binop    : ?loc:Location.t -> constant' -> expression -> expression -> expression
+val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
 val e_look_up : ?loc:Location.t -> expression -> expression -> expression
-val e_assign : ?loc:Location.t -> string -> access_path -> expression -> expression
-val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching
+val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
 val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
 
 val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
-val ez_e_record : ?loc:Location.t -> ( string * expression ) list -> expression
 
 val e_typed_none : ?loc:Location.t -> type_expression -> expression
 
@@ -110,20 +108,18 @@ val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expre
 val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
 val e_record : ?loc:Location.t -> expr Map.String.t -> expression
 val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
+val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
 
-val e_ez_record : ?loc:Location.t -> ( string * expr ) list -> expression
 (*
 val get_e_accessor : expression' -> ( expression * access_path ) result
 *)
 
-val assert_e_accessor : expression' -> unit result
+val assert_e_accessor : expression_content -> unit result
 
-val get_access_record : access -> string result
+val get_e_pair : expression_content -> ( expression * expression ) result
 
-val get_e_pair : expression' -> ( expression * expression ) result
-
-val get_e_list : expression' -> ( expression list ) result
-val get_e_tuple : expression' -> ( expression list ) result
+val get_e_list : expression_content -> ( expression list ) result
+val get_e_tuple : expression_content -> ( expression list ) result
 (*
 val get_e_failwith : expression -> expression result 
 val is_e_failwith : expression -> bool

src/stages/ast_simplified/misc.ml

@@ -1,8 +1,7 @@
 open Trace
 open Types
 
-include Stage_common.Misc
-
+open Stage_common.Helpers
 module Errors = struct
   let different_literals_because_different_types name a b () =
     let title () = "literals have different types: " ^ name in
@@ -56,6 +55,8 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
   | Literal_bytes a, Literal_bytes b when a = b -> ok ()
   | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b
   | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
+  | Literal_void, Literal_void -> ok ()
+  | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
   | Literal_unit, Literal_unit -> ok ()
   | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
   | Literal_address a, Literal_address b when a = b -> ok ()
@@ -77,19 +78,20 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
   | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
 
 let rec assert_value_eq (a, b: (expression * expression )) : unit result =
+  Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b;
   let error_content () =
     Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b
   in
   trace (fun () -> error (thunk "not equal") error_content ()) @@
-  match (a.expression , b.expression) with
+  match (a.expression_content , b.expression_content) with
   | E_literal a , E_literal b ->
       assert_literal_eq (a, b)
   | E_literal _ , _ ->
     simple_fail "comparing a literal with not a literal"
-  | E_constant (ca, lsta) , E_constant (cb, lstb) when ca = cb -> (
+  | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (
       let%bind lst =
         generic_try (simple_error "constants with different number of elements")
-          (fun () -> List.combine lsta lstb) in
+          (fun () -> List.combine ca.arguments cb.arguments) in
       let%bind _all = bind_list @@ List.map assert_value_eq lst in
       ok ()
     )
@@ -103,8 +105,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
       in
       fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ())
 
-  | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
-      let%bind _eq = assert_value_eq (a, b) in
+  | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> (
+      let%bind _eq = assert_value_eq (ca.element, cb.element) in
       ok ()
     )
   | E_constructor _, E_constructor _ ->
@@ -112,15 +114,6 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
   | E_constructor _, _ ->
       simple_fail "comparing constructor with other expression"
 
-  | E_tuple lsta, E_tuple lstb -> (
-      let%bind lst =
-        generic_try (simple_error "tuples with different number of elements")
-          (fun () -> List.combine lsta lstb) in
-      let%bind _all = bind_list @@ List.map assert_value_eq lst in
-      ok ()
-    )
-  | E_tuple _, _ ->
-      simple_fail "comparing tuple with other expression"
 
   | E_record sma, E_record smb -> (
       let aux _ a b =
@@ -134,17 +127,17 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
   | E_record _, _ ->
       simple_fail "comparing record with other expression"
   
-  | E_update ura, E_update urb ->
+  | E_record_update ura, E_record_update urb ->
     let _ = 
       generic_try (simple_error "Updating different record") @@ 
       fun () -> assert_value_eq (ura.record, urb.record) in
-    let aux ((Label a,expra),(Label b, exprb))=
-      assert (String.equal a b);
-      assert_value_eq (expra,exprb)
+    let aux (Label a,Label b) =
+      assert (String.equal a b)
     in
-    let%bind _all = aux (ura.update, urb.update) in
+    let () = aux (ura.path, urb.path) in
+    let%bind () = assert_value_eq (ura.update,urb.update) in
     ok ()
-  | E_update _, _ ->
+  | E_record_update _, _ ->
      simple_fail "comparing record update with other expression"
 
   | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
@@ -185,13 +178,13 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
   | E_set _, _ ->
       simple_fail "comparing set with other expression"
 
-  | (E_ascription (a , _) ,  _b') -> assert_value_eq (a , b)
-  | (_a' , E_ascription (b , _)) -> assert_value_eq (a , b)
+  | (E_ascription a ,  _b') -> assert_value_eq (a.anno_expr , b)
+  | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
   | (E_variable _, _) | (E_lambda _, _)
   | (E_application _, _) | (E_let_in _, _)
-  | (E_accessor _, _)
-  | (E_look_up _, _) | (E_matching _, _) | (E_sequence _, _)
-  | (E_loop _, _) | (E_assign _, _) | (E_skip, _) -> simple_fail "comparing not a value"
+  | (E_record_accessor _, _)
+  | (E_look_up _, _) | (E_matching _, _)
+  | (E_loop _, _) | (E_skip, _) -> simple_fail "comparing not a value"
 
 let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)
 

src/stages/ast_simplified/misc.mli

@@ -1,7 +1,6 @@
 open Trace
 open Types
 
-include module type of Stage_common.Misc
 
 (*
 

src/stages/ast_simplified/types.ml

@@ -1,14 +1,19 @@
 [@@@warning "-30"]
+
 module Location = Simple_utils.Location
+
+module Ast_simplified_parameter = struct
+  type type_meta = unit
+end
+
 include Stage_common.Types
 
+(*include Ast_generic_type(Ast_simplified_parameter)
+*)
+include Ast_generic_type (Ast_simplified_parameter)
+
+type inline = bool 
 type program = declaration Location.wrap list
-
-and inline = bool
-
-and type_expression =  {
-  type_expression' : type_expression type_expression'
-  }
 and declaration =
   | Declaration_type of (type_variable * type_expression)
 
@@ -19,59 +24,91 @@ and declaration =
    *   an expression *)
   | Declaration_constant of (expression_variable * type_expression option * inline * expression)
 
-and expr = expression
+(* | Macro_declaration of macro_declaration *)
+and expression = {expression_content: expression_content; location: Location.t}
 
-and lambda = {
-  binder : (expression_variable * type_expression option) ;
-  input_type : type_expression option ;
-  output_type : type_expression option ;
-  result : expr ;
-}
-
-and let_in = {
-  binder     : (expression_variable * type_expression option) ;
-  rhs        : expr ;
-  result     : expr ;
-  inline     : inline;
-}
-
-and expression' =
+and expression_content =
   (* Base *)
   | E_literal of literal
-  | E_constant of (constant * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
   | E_variable of expression_variable
+  | E_application of application
   | E_lambda of lambda
-  | E_application of (expr * expr)
   | E_let_in of let_in
-  (* E_Tuple *)
-  | E_tuple of expr list
-  (* Sum *)
-  | E_constructor of (constructor * expr) (* For user defined constructors *)
-  (* E_record *)
-  | E_record of expr label_map
-  (* TODO: Change it to (expr * access) *)
-  | E_accessor of (expr * access_path)
-  | E_update of update
-  (* Data Structures *)
-  | E_map of (expr * expr) list
-  | E_big_map of (expr * expr) list
-  | E_list of expr list
-  | E_set of expr list
-  | E_look_up of (expr * expr)
-  (* Matching *)
-  | E_matching of (expr * matching_expr)
-  (* Replace Statements *)
-  | E_sequence of (expr * expr)
-  | E_loop of (expr * expr)
-  | E_assign of (expression_variable * access_path * expr)
   | E_skip
-  (* Annotate *)
-  | E_ascription of expr * type_expression
+  (* Variant *)
+  | E_constructor of constructor (* For user defined constructors *)
+  | E_matching of matching
+  (* Record *)
+  | E_record of expression label_map
+  | E_record_accessor of accessor
+  | E_record_update of update
+  (* Data Structures *)
+  (* TODO : move to constant*)
+  | E_map of (expression * expression) list (*move to operator *)
+  | E_big_map of (expression * expression) list (*move to operator *)
+  | E_list of expression list
+  | E_set of expression list
+  | E_look_up of (expression * expression)
+  (* Advanced *)
+  | E_loop of loop
+  | E_ascription of ascription
 
-and expression = {
-  expression : expression' ;
-  location : Location.t ;
-}
-and update = { record: expr; update: (label *expr) }
+and constant =
+  { cons_name: constant' (* this is at the end because it is huge *)
+  ; arguments: expression list }
 
-and matching_expr = (expr,unit) matching
+and application = {expr1: expression; expr2: expression}
+
+and lambda =
+  { binder: expression_variable * type_expression option
+  ; input_type: type_expression option
+  ; output_type: type_expression option
+  ; result: expression }
+
+and let_in =
+  { let_binder: expression_variable * type_expression option
+  ; mut: bool
+  ; rhs: expression
+  ; let_result: expression
+  ; inline: bool }
+
+and constructor = {constructor: constructor'; element: expression}
+
+and accessor = {expr: expression; label: label}
+
+and update = {record: expression; path: label ; update: expression}
+
+and loop = {condition: expression; body: expression}
+
+and matching_expr = (expr,unit) matching_content
+and matching =
+  { matchee: expression
+  ; cases: matching_expr
+  }
+
+and ascription = {anno_expr: expression; type_annotation: type_expression}
+
+and environment_element_definition =
+  | ED_binder
+  | ED_declaration of (expression * free_variables)
+
+and free_variables = expression_variable list
+
+and environment_element =
+  { type_value: type_expression
+  ; source_environment: full_environment
+  ; definition: environment_element_definition }
+
+and environment = (expression_variable * environment_element) list
+
+and type_environment = (type_variable * type_expression) list
+
+(* SUBST ??? *)
+and small_environment = environment * type_environment
+
+and full_environment = small_environment List.Ne.t
+
+and expr = expression
+
+and texpr = type_expression

src/stages/ast_typed/PP.ml

@@ -2,26 +2,60 @@
 open Types
 open Format
 open PP_helpers
+
 include Stage_common.PP
+include Ast_PP_type(Ast_typed_type_parameter)
 
-let list_sep_d x = list_sep x (const " , ")
+let expression_variable ppf (ev : expression_variable) : unit =
+  fprintf ppf "%a" Var.pp ev
 
 
-let rec type_value' ppf (tv':type_value type_expression') : unit =
-  type_expression' type_value ppf tv'
+let rec expression ppf (e : expression) =
+  match e.expression_content with
+  | E_literal l ->
+      literal ppf l
+  | E_variable n ->
+      fprintf ppf "%a" expression_variable n
+  | E_application app ->
+      fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2
+  | E_constructor c ->
+      fprintf ppf "%a(%a)" constructor c.constructor expression c.element
+  | E_constant c ->
+      fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
+        c.arguments
+  | E_record m ->
+      fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
+  | E_record_accessor ra ->
+      fprintf ppf "%a.%a" expression ra.expr label ra.label
+  | E_record_update {record; path; update} ->
+      fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
+  | E_map m ->
+      fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
+  | E_big_map m ->
+      fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
+  | E_list lst ->
+      fprintf ppf "list[%a]" (list_sep_d expression) lst
+  | E_set lst ->
+      fprintf ppf "set[%a]" (list_sep_d expression) lst
+  | E_look_up (ds, ind) ->
+      fprintf ppf "(%a)[%a]" expression ds expression ind
+  | E_lambda {binder; result} ->
+      fprintf ppf "lambda (%a) return %a" expression_variable binder
+        expression result
+  | E_matching {matchee; cases;} ->
+      fprintf ppf "match %a with %a" expression matchee (matching expression) cases
+  | E_loop l ->
+      fprintf ppf "while %a do %a" expression l.condition expression l.body
+  | E_let_in {let_binder; rhs; let_result; inline} ->
+      fprintf ppf "let %a = %a%a in %a" expression_variable let_binder expression
+        rhs option_inline inline expression let_result
 
-and type_value ppf (tv:type_value) : unit =
-  type_value' ppf tv.type_value'
+and assoc_expression ppf : expr * expr -> unit =
+ fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
 
-let rec annotated_expression ppf (ae:annotated_expression) : unit =
-  match ae.type_annotation.simplified with
-  | _ -> fprintf ppf "@[<v>%a:%a@]" expression ae.expression type_value ae.type_annotation
+and single_record_patch ppf ((p, expr) : label * expr) =
+  fprintf ppf "%a <- %a" label p expression expr
 
-and lambda ppf l =
-  let ({ binder ; body } : lambda) = l in
-  fprintf ppf "(lambda (%a) -> %a)"
-    name binder
-    annotated_expression body
 
 and option_inline ppf inline = 
   if inline then 
@@ -29,68 +63,28 @@ and option_inline ppf inline =
   else
     fprintf ppf ""
 
-and expression ppf (e:expression) : unit =
-  match e with
-  | E_literal l -> Stage_common.PP.literal ppf l
-  | E_constant (b, lst) -> fprintf ppf "(e_constant %a(%a))" constant b (list_sep_d annotated_expression) lst
-  | E_constructor (c, lst) -> fprintf ppf "(e_constructor %a(%a))" constructor c annotated_expression lst
-  | E_variable a -> fprintf ppf "(e_var %a)" name a
-  | E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg
-  | E_lambda l -> fprintf ppf "%a" lambda l
-  | E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i
-  | E_record_accessor (ae, l) -> fprintf ppf "%a.%a" annotated_expression ae label l
-  | E_record_update (ae, (path,expr)) -> fprintf ppf "%a with record[%a=%a]" annotated_expression ae Stage_common.PP.label path annotated_expression expr
-  | E_tuple lst -> fprintf ppf "tuple[@;  @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst
-  | E_record m -> fprintf ppf "record[%a]" (lmap_sep annotated_expression (const " , ")) m
-  | E_map m -> fprintf ppf "map[@;  @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
-  | E_big_map m -> fprintf ppf "big_map[@;  @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
-  | E_list m -> fprintf ppf "list[@;  @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
-  | E_set m -> fprintf ppf "set[@;  @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
-  | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
-  | E_matching (ae, m) ->
-      fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
-  | E_sequence (a , b) -> fprintf ppf "(e_seq %a ; %a)" annotated_expression a annotated_expression b
-  | E_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body
-  | E_assign (name , path , expr) ->
-    fprintf ppf "%a.%a := %a"
-      Stage_common.PP.name name.type_name
-      PP_helpers.(list_sep pre_access (const ".")) path
-      annotated_expression expr
-  | E_let_in { binder; rhs; result; inline } ->
-    fprintf ppf "let %a = %a%a in %a" name binder annotated_expression rhs option_inline inline annotated_expression result
-
-and value ppf v = annotated_expression ppf v
-
-and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
-  fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
-
-and single_record_patch ppf ((s, ae) : string * ae) =
-  fprintf ppf "%s <- %a" s annotated_expression ae
-
-and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor * expression_variable) * a -> unit =
+and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
   fun f ppf ((c,n),a) ->
-  fprintf ppf "| %a %a -> %a" constructor c name n f a
+  fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
 
-and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching -> unit = fun f ppf m -> match m with
+and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching_content -> unit = fun f ppf m -> match m with
   | Match_tuple ((lst, b),_) ->
-      fprintf ppf "let (%a) = %a" (list_sep_d Stage_common.PP.name) lst f b
+      fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
   | Match_variant (lst, _) ->
       fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
   | Match_bool {match_true ; match_false} ->
       fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
   | Match_list {match_nil ; match_cons = (hd_name, tl_name, match_cons, _)} ->
-      fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil Stage_common.PP.name hd_name Stage_common.PP.name tl_name f match_cons
+      fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd_name expression_variable tl_name f match_cons
   | Match_option {match_none ; match_some = (some, match_some, _)} ->
-      fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
+      fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
 
-and pre_access ppf (a:access) = match a with
-  | Access_record n -> fprintf ppf ".%s" n
-  | Access_tuple i -> fprintf ppf ".%d" i
-
-let declaration ppf (d:declaration) =
+let declaration ppf (d : declaration) =
   match d with
-  | Declaration_constant ({name ; annotated_expression = ae} , inline, _) ->
-      fprintf ppf "const %a = %a%a" Stage_common.PP.name name annotated_expression ae option_inline inline
+  | Declaration_constant (name, expr, inline,_) ->
+      fprintf ppf "const %a = %a%a" expression_variable name expression expr option_inline inline
 
-let program ppf (p:program) =
-  fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)
+let program ppf (p : program) =
+  fprintf ppf "@[<v>%a@]"
+    (list_sep declaration (tag "@;"))
+    (List.map Location.unwrap p)

src/stages/ast_typed/PP.mli

@@ -1,33 +0,0 @@
-open Types
-open Format
-
-val value : formatter -> annotated_expression -> unit
-
-val type_value : formatter -> type_value -> unit
-
-val single_record_patch : formatter -> ( string * ae ) -> unit
-
-val program : formatter -> program -> unit
-
-val expression : formatter -> expression -> unit
-
-val literal : formatter -> literal -> unit
-
-val annotated_expression : formatter -> annotated_expression -> unit
-
-(*
-val list_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a list -> unit
-val smap_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a Map.String.t -> unit
-
-val lambda : formatter -> lambda -> unit
-
-val assoc_annotated_expression : formatter -> (ae * ae) -> unit
-
-val matching_variant_case : ( formatter -> 'a  -> unit ) -> formatter -> ( T.constructor_name * name ) * 'a -> unit
-
-val matching : ( formatter -> 'a -> unit ) -> formatter -> 'a matching -> unit
-
-val pre_access : formatter -> access -> unit
-
-val declaration : formatter -> declaration -> unit
-*)

src/stages/ast_typed/combinators.ml

@@ -13,7 +13,7 @@ module Errors = struct
     let message () =
       Format.asprintf "Expected the type %s but got the type %a"
         expected_type
-        PP.type_value actual_type in
+        PP.type_expression actual_type in
     error (thunk "Expected a different type") message
 
   let declaration_not_found expected_declaration () =
@@ -23,177 +23,182 @@ module Errors = struct
     error (thunk "No declaration with the given name") message
 end
 
-let make_t type_value' simplified = { type_value' ; simplified }
-let make_a_e ?(location = Location.generated) expression type_annotation environment = {
-  expression ;
-  type_annotation ;
+let make_t type_content simplified = { type_content ; type_meta=simplified }
+let make_a_e ?(location = Location.generated) expression_content type_expression environment = {
+  expression_content ;
+  type_expression ;
   environment ;
   location ;
 }
-let make_n_e name a_e = { name ; annotated_expression = a_e }
 let make_n_t type_name type_value = { type_name ; type_value }
 
-let t_signature ?s ()  : type_value = make_t (T_constant TC_signature) s
-let t_chain_id ?s ()   : type_value = make_t (T_constant TC_chain_id) s
-let t_bool ?s ()       : type_value = make_t (T_constant TC_bool) s
-let t_string ?s ()     : type_value = make_t (T_constant TC_string) s
-let t_bytes ?s ()      : type_value = make_t (T_constant TC_bytes) s
-let t_key ?s ()        : type_value = make_t (T_constant TC_key) s
-let t_key_hash ?s ()   : type_value = make_t (T_constant TC_key_hash) s
-let t_int ?s ()        : type_value = make_t (T_constant TC_int) s
-let t_address ?s ()    : type_value = make_t (T_constant TC_address) s
-let t_operation ?s ()  : type_value = make_t (T_constant TC_operation) s
-let t_nat ?s ()        : type_value = make_t (T_constant TC_nat) s
-let t_mutez ?s ()      : type_value = make_t (T_constant TC_mutez) s
-let t_timestamp ?s ()  : type_value = make_t (T_constant TC_timestamp) s
-let t_unit ?s ()       : type_value = make_t (T_constant TC_unit) s
-let t_option o ?s ()   : type_value = make_t (T_operator (TC_option o)) s
-let t_tuple lst ?s ()  : type_value = make_t (T_operator (TC_tuple lst)) s
-let t_variable t ?s () : type_value = make_t (T_variable t) s
-let t_list t ?s ()     : type_value = make_t (T_operator (TC_list t)) s
-let t_set t ?s ()      : type_value = make_t (T_operator (TC_set t)) s
-let t_contract t ?s () : type_value = make_t (T_operator (TC_contract t)) s
-let t_pair a b ?s ()   : type_value = t_tuple [a ; b] ?s ()
+let t_signature ?s ()  : type_expression = make_t (T_constant TC_signature) s
+let t_chain_id ?s ()   : type_expression = make_t (T_constant TC_chain_id) s
+let t_bool ?s ()       : type_expression = make_t (T_constant TC_bool) s
+let t_string ?s ()     : type_expression = make_t (T_constant TC_string) s
+let t_bytes ?s ()      : type_expression = make_t (T_constant TC_bytes) s
+let t_key ?s ()        : type_expression = make_t (T_constant TC_key) s
+let t_key_hash ?s ()   : type_expression = make_t (T_constant TC_key_hash) s
+let t_int ?s ()        : type_expression = make_t (T_constant TC_int) s
+let t_address ?s ()    : type_expression = make_t (T_constant TC_address) s
+let t_operation ?s ()  : type_expression = make_t (T_constant TC_operation) s
+let t_nat ?s ()        : type_expression = make_t (T_constant TC_nat) s
+let t_mutez ?s ()      : type_expression = make_t (T_constant TC_mutez) s
+let t_timestamp ?s ()  : type_expression = make_t (T_constant TC_timestamp) s
+let t_unit ?s ()       : type_expression = make_t (T_constant TC_unit) s
+let t_option o ?s ()   : type_expression = make_t (T_operator (TC_option o)) s
+let t_variable t ?s () : type_expression = make_t (T_variable t) s
+let t_list t ?s ()     : type_expression = make_t (T_operator (TC_list t)) s
+let t_set t ?s ()      : type_expression = make_t (T_operator (TC_set t)) s
+let t_contract t ?s () : type_expression = make_t (T_operator (TC_contract t)) s
 
-let t_record m ?s () : type_value = make_t (T_record m) s
-let make_t_ez_record (lst:(label * type_value) list) : type_value =
-  let aux prev (k, v) = LMap.add k v prev in
-  let map = List.fold_left aux LMap.empty lst in
+let t_record m ?s () : type_expression = make_t (T_record m) s
+let make_t_ez_record (lst:(string * type_expression) list) : type_expression =
+  let lst = List.map (fun (x,y) -> (Label x, y) ) lst in
+  let map = LMap.of_list lst in
   make_t (T_record map) None
-let ez_t_record lst ?s () : type_value =
+let ez_t_record lst ?s () : type_expression =
   let m = LMap.of_list lst in
   t_record m ?s ()
+let t_pair a b ?s ()   : type_expression = ez_t_record [(Label "0",a) ; (Label "1",b)] ?s ()
 
 let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s
 let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s
 
-let t_sum m ?s () : type_value = make_t (T_sum m) s
-let make_t_ez_sum (lst:(constructor * type_value) list) : type_value =
+let t_sum m ?s () : type_expression = make_t (T_sum m) s
+let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression =
   let aux prev (k, v) = CMap.add k v prev in
   let map = List.fold_left aux CMap.empty lst in
   make_t (T_sum map) None
 
-let t_function param result ?s () : type_value = make_t (T_arrow (param, result)) s
-let t_shallow_closure param result ?s () : type_value = make_t (T_arrow (param, result)) s
+let t_function param result ?s () : type_expression = make_t (T_arrow {type1=param; type2=result}) s
+let t_shallow_closure param result ?s () : type_expression = make_t (T_arrow {type1=param; type2=result}) s
 
-let get_type_annotation (x:annotated_expression) = x.type_annotation
-let get_type' (x:type_value) = x.type_value'
-let get_environment (x:annotated_expression) = x.environment
-let get_expression (x:annotated_expression) = x.expression
+let get_type_expression (x:expression) = x.type_expression
+let get_type' (x:type_expression) = x.type_content
+let get_environment (x:expression) = x.environment
+let get_expression (x:expression) = x.expression_content
 
-let get_lambda e : _ result = match e with
+let get_lambda e : _ result = match e.expression_content with
   | E_lambda l -> ok l
   | _ -> fail @@ Errors.not_a_x_expression "lambda" e ()
 
 let get_lambda_with_type e =
-  match (e.expression , e.type_annotation.type_value') with
-  | E_lambda l , T_arrow (i,o) -> ok (l , (i,o))
-  | _ -> fail @@ Errors.not_a_x_expression "lambda with functional type" e.expression ()
+  match (e.expression_content , e.type_expression.type_content) with
+  | E_lambda l , T_arrow {type1;type2} -> ok (l , (type1,type2))
+  | _ -> simple_fail "not a lambda with functional type"
 
-let get_t_bool (t:type_value) : unit result = match t.type_value' with
+let get_t_bool (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_bool) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "bool" t ()
 
-let get_t_int (t:type_value) : unit result = match t.type_value' with
+let get_t_int (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_int) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "int" t ()
 
-let get_t_nat (t:type_value) : unit result = match t.type_value' with
+let get_t_nat (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_nat) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "nat" t ()
 
-let get_t_unit (t:type_value) : unit result = match t.type_value' with
+let get_t_unit (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_unit) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "unit" t ()
 
-let get_t_mutez (t:type_value) : unit result = match t.type_value' with
+let get_t_mutez (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_mutez) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "tez" t ()
 
-let get_t_bytes (t:type_value) : unit result = match t.type_value' with
+let get_t_bytes (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_bytes) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "bytes" t ()
 
-let get_t_string (t:type_value) : unit result = match t.type_value' with
+let get_t_string (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_string) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "string" t ()
 
-let get_t_contract (t:type_value) : type_value result = match t.type_value' with
+let get_t_contract (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_contract x) -> ok x
   | _ -> fail @@ Errors.not_a_x_type "contract" t ()
 
-let get_t_option (t:type_value) : type_value result = match t.type_value' with
+let get_t_option (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_option o) -> ok o
   | _ -> fail @@ Errors.not_a_x_type "option" t ()
 
-let get_t_list (t:type_value) : type_value result = match t.type_value' with
+let get_t_list (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_list l) -> ok l
   | _ -> fail @@ Errors.not_a_x_type "list" t ()
 
-let get_t_set (t:type_value) : type_value result = match t.type_value' with
+let get_t_set (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_set s) -> ok s
   | _ -> fail @@ Errors.not_a_x_type "set" t ()
 
-let get_t_key (t:type_value) : unit result = match t.type_value' with
+let get_t_key (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_key) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "key" t ()
 
-let get_t_signature (t:type_value) : unit result = match t.type_value' with
+let get_t_signature (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_signature) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "signature" t ()
 
-let get_t_key_hash (t:type_value) : unit result = match t.type_value' with
+let get_t_key_hash (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_key_hash) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "key_hash" t ()
 
-let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
-  | T_operator (TC_tuple lst) -> ok lst
+let tuple_of_record (m: _ LMap.t) =
+  let aux i = 
+    let opt = LMap.find_opt (Label (string_of_int i)) m in
+    Option.bind (fun opt -> Some (opt,i+1)) opt
+  in
+  Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
+
+let get_t_tuple (t:type_expression) : type_expression list result = match t.type_content with
+  | T_record lst -> ok @@ tuple_of_record lst
   | _ -> fail @@ Errors.not_a_x_type "tuple" t ()
 
-let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_value' with
-  | T_operator (TC_tuple lst) ->
+let get_t_pair (t:type_expression) : (type_expression * type_expression) result = match t.type_content with
+  | T_record m ->
+      let lst = tuple_of_record m in
       let%bind () =
         trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@
         Assert.assert_list_size lst 2 in
       ok List.(nth lst 0 , nth lst 1)
   | _ -> fail @@ Errors.not_a_x_type "pair (tuple with two elements)" t ()
 
-let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
-  | T_arrow (a,r) -> ok (a,r)
-  | T_operator (TC_arrow (a , b)) -> ok (a , b)
-  | _ -> fail @@ Errors.not_a_x_type "function" t ()
+let get_t_function (t:type_expression) : (type_expression * type_expression) result = match t.type_content with
+  | T_arrow {type1;type2} -> ok (type1,type2)
+  | _ -> simple_fail "not a function"
 
-let get_t_sum (t:type_value) : type_value constructor_map result = match t.type_value' with
+let get_t_sum (t:type_expression) : type_expression constructor_map result = match t.type_content with
   | T_sum m -> ok m
   | _ -> fail @@ Errors.not_a_x_type "sum" t ()
 
-let get_t_record (t:type_value) : type_value label_map result = match t.type_value' with
+let get_t_record (t:type_expression) : type_expression label_map result = match t.type_content with
   | T_record m -> ok m
   | _ -> fail @@ Errors.not_a_x_type "record" t ()
 
-let get_t_map (t:type_value) : (type_value * type_value) result =
-  match t.type_value' with
+let get_t_map (t:type_expression) : (type_expression * type_expression) result =
+  match t.type_content with
   | T_operator (TC_map (k,v)) -> ok (k, v)
   | _ -> fail @@ Errors.not_a_x_type "map" t ()
 
-let get_t_big_map (t:type_value) : (type_value * type_value) result =
-  match t.type_value' with
+let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
+  match t.type_content with
   | T_operator (TC_big_map (k,v)) -> ok (k, v)
   | _ -> fail @@ Errors.not_a_x_type "big_map" t ()
 
-let get_t_map_key : type_value -> type_value result = fun t ->
+let get_t_map_key : type_expression -> type_expression result = fun t ->
   let%bind (key , _) = get_t_map t in
   ok key
 
-let get_t_map_value : type_value -> type_value result = fun t ->
+let get_t_map_value : type_expression -> type_expression result = fun t ->
   let%bind (_ , value) = get_t_map t in
   ok value
 
-let get_t_big_map_key : type_value -> type_value result = fun t ->
+let get_t_big_map_key : type_expression -> type_expression result = fun t ->
   let%bind (key , _) = get_t_big_map t in
   ok key
 
-let get_t_big_map_value : type_value -> type_value result = fun t ->
+let get_t_big_map_value : type_expression -> type_expression result = fun t ->
   let%bind (_ , value) = get_t_big_map t in
   ok value
 
@@ -204,12 +209,12 @@ let assert_t_map = fun t ->
 let is_t_map = Function.compose to_bool get_t_map
 let is_t_big_map = Function.compose to_bool get_t_big_map
 
-let assert_t_mutez : type_value -> unit result = get_t_mutez
+let assert_t_mutez : type_expression -> unit result = get_t_mutez
 let assert_t_key = get_t_key
 let assert_t_signature = get_t_signature
 let assert_t_key_hash = get_t_key_hash
 
-let assert_t_contract (t:type_value) : unit result = match t.type_value' with
+let assert_t_contract (t:type_expression) : unit result = match t.type_content with
   | T_operator (TC_contract _) -> ok ()
   | _ -> simple_fail "not a contract"
 
@@ -228,57 +233,56 @@ let assert_t_bytes = fun t ->
   let%bind _ = get_t_bytes t in
   ok ()
 
-let assert_t_operation (t:type_value) : unit result =
-  match t.type_value' with
+let assert_t_operation (t:type_expression) : unit result =
+  match t.type_content with
   | T_constant (TC_operation) -> ok ()
   | _ -> simple_fail "assert: not an operation"
 
-let assert_t_list_operation (t : type_value) : unit result =
+let assert_t_list_operation (t : type_expression) : unit result =
   let%bind t' = get_t_list t in
   assert_t_operation t'
 
-let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with
+let assert_t_int : type_expression -> unit result = fun t -> match t.type_content with
   | T_constant (TC_int) -> ok ()
   | _ -> simple_fail "not an int"
 
-let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with
+let assert_t_nat : type_expression -> unit result = fun t -> match t.type_content with
   | T_constant (TC_nat) -> ok ()
   | _ -> simple_fail "not an nat"
 
-let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v
-let assert_t_unit : type_value -> unit result = fun v -> get_t_unit v
+let assert_t_bool : type_expression -> unit result = fun v -> get_t_bool v
+let assert_t_unit : type_expression -> unit result = fun v -> get_t_unit v
 
-let e_record map : expression = E_record map
-let ez_e_record (lst : (label * ae) list) : expression =
+let e_record map : expression_content = E_record map
+let ez_e_record (lst : (label * expression) list) : expression_content =
   let aux prev (k, v) = LMap.add k v prev in
   let map = List.fold_left aux LMap.empty lst in
   e_record map
-let e_some s : expression = E_constant (C_SOME, [s])
-let e_none () : expression = E_constant (C_NONE, [])
+let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]}
+let e_none (): expression_content = E_constant {cons_name=C_NONE; arguments=[]}
 
-let e_map lst : expression = E_map lst
+let e_map lst : expression_content = E_map lst
 
-let e_unit () : expression = E_literal (Literal_unit)
-let e_int n : expression = E_literal (Literal_int n)
-let e_nat n : expression = E_literal (Literal_nat n)
-let e_mutez n : expression = E_literal (Literal_mutez n)
-let e_bool b : expression = E_literal (Literal_bool b)
-let e_string s : expression = E_literal (Literal_string s)
-let e_bytes s : expression = E_literal (Literal_bytes s)
-let e_timestamp s : expression = E_literal (Literal_timestamp s)
-let e_address s : expression = E_literal (Literal_address s)
-let e_signature s : expression = E_literal (Literal_signature s)
-let e_key s : expression = E_literal (Literal_key s)
-let e_key_hash s : expression = E_literal (Literal_key_hash s)
-let e_chain_id s : expression = E_literal (Literal_chain_id s)
-let e_operation s : expression = E_literal (Literal_operation s)
-let e_lambda l : expression = E_lambda l
-let e_pair a b : expression = E_tuple [a; b]
-let e_application a b : expression = E_application (a , b)
-let e_variable v : expression = E_variable v
-let e_list lst : expression = E_list lst
-let e_let_in binder inline rhs result = E_let_in { binder ; rhs ; result; inline }
-let e_tuple lst : expression = E_tuple lst
+let e_unit () : expression_content =     E_literal (Literal_unit)
+let e_int n : expression_content = E_literal (Literal_int n)
+let e_nat n : expression_content = E_literal (Literal_nat n)
+let e_mutez n : expression_content = E_literal (Literal_mutez n)
+let e_bool b : expression_content = E_literal (Literal_bool b)
+let e_string s : expression_content = E_literal (Literal_string s)
+let e_bytes s : expression_content = E_literal (Literal_bytes s)
+let e_timestamp s : expression_content = E_literal (Literal_timestamp s)
+let e_address s : expression_content = E_literal (Literal_address s)
+let e_signature s : expression_content = E_literal (Literal_signature s)
+let e_key s : expression_content = E_literal (Literal_key s)
+let e_key_hash s : expression_content = E_literal (Literal_key_hash s)
+let e_chain_id s : expression_content = E_literal (Literal_chain_id s)
+let e_operation s : expression_content = E_literal (Literal_operation s)
+let e_lambda l : expression_content = E_lambda l
+let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)]
+let e_application expr1 expr2 : expression_content = E_application {expr1;expr2}
+let e_variable v : expression_content = E_variable v
+let e_list lst : expression_content = E_list lst
+let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline }
 
 let e_a_unit = make_a_e (e_unit ()) (t_unit ())
 let e_a_int n = make_a_e (e_int n) (t_int ())
@@ -287,44 +291,44 @@ let e_a_mutez n = make_a_e (e_mutez n) (t_mutez ())
 let e_a_bool b = make_a_e (e_bool b) (t_bool ())
 let e_a_string s = make_a_e (e_string s) (t_string ())
 let e_a_address s = make_a_e (e_address s) (t_address ())
-let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ())
-let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ())
+let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_expression b.type_expression ())
+let e_a_some s = make_a_e (e_some s) (t_option s.type_expression ())
 let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ())
 let e_a_none t = make_a_e (e_none ()) (t_option t ())
-let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ())
-let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_annotation r) ())
-let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b)
+let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_expression r) ())
+let e_a_application a b = make_a_e (e_application a b) (get_type_expression b)
 let e_a_variable v ty = make_a_e (e_variable v) ty
-let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ())
+let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ())
 let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ())
 let e_a_list lst t = make_a_e (e_list lst) (t_list t ())
-let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_annotation body)
+let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_expression body)
 
-let get_a_int (t:annotated_expression) =
-  match t.expression with
+
+let get_a_int (t:expression) =
+  match t.expression_content with
   | E_literal (Literal_int n) -> ok n
   | _ -> simple_fail "not an int"
 
-let get_a_unit (t:annotated_expression) =
-  match t.expression with
+let get_a_unit (t:expression) =
+  match t.expression_content with
   | E_literal (Literal_unit) -> ok ()
   | _ -> simple_fail "not a unit"
 
-let get_a_bool (t:annotated_expression) =
-  match t.expression with
+let get_a_bool (t:expression) =
+  match t.expression_content with
   | E_literal (Literal_bool b) -> ok b
   | _ -> simple_fail "not a bool"
 
 
 let get_a_record_accessor = fun t ->
-  match t.expression with
-  | E_record_accessor (a , b) -> ok (a , b)
+  match t.expression_content with
+  | E_record_accessor {expr ; label} -> ok (expr , label)
   | _ -> simple_fail "not an accessor"
 
 let get_declaration_by_name : program -> string -> declaration result = fun p name ->
   let aux : declaration -> bool = fun declaration ->
     match declaration with
-    | Declaration_constant (d , _, _) -> d.name = Var.of_name name
+    | Declaration_constant (d, _, _, _) -> d = Var.of_name name
   in
   trace_option (Errors.declaration_not_found name ()) @@
   List.find_opt aux @@ List.map Location.unwrap p

src/stages/ast_typed/combinators.mli

@@ -1,162 +1,155 @@
 open Trace
 open Types
-open Stage_common.Types
 
-val make_n_e : expression_variable -> annotated_expression -> named_expression
-val make_n_t : expression_variable -> type_value -> named_type_value
-val make_t : type_value' -> S.type_expression option -> type_value
-val make_a_e : ?location:Location.t -> expression -> type_value -> full_environment -> annotated_expression
+val make_n_t : type_variable -> type_expression -> named_type_content
+val make_t : type_content -> S.type_expression option -> type_expression
+val make_a_e : ?location:Location.t -> expression_content -> type_expression -> full_environment -> expression
 
-val t_bool : ?s:S.type_expression -> unit -> type_value
-val t_string : ?s:S.type_expression -> unit -> type_value
-val t_bytes : ?s:S.type_expression -> unit -> type_value
-val t_key : ?s:S.type_expression -> unit -> type_value
-val t_key_hash : ?s:S.type_expression -> unit -> type_value
-val t_operation : ?s:S.type_expression -> unit -> type_value
-val t_timestamp : ?s:S.type_expression -> unit -> type_value
-val t_set : type_value -> ?s:S.type_expression -> unit -> type_value
-val t_contract : type_value -> ?s:S.type_expression -> unit -> type_value
-val t_int : ?s:S.type_expression -> unit -> type_value
-val t_nat : ?s:S.type_expression -> unit -> type_value
-val t_mutez : ?s:S.type_expression -> unit -> type_value
-val t_address : ?s:S.type_expression -> unit -> type_value
-val t_chain_id : ?s:S.type_expression -> unit -> type_value
-val t_signature : ?s:S.type_expression -> unit -> type_value
-val t_unit : ?s:S.type_expression -> unit -> type_value
-val t_option : type_value -> ?s:S.type_expression -> unit -> type_value
-val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
-val t_list  : type_value -> ?s:S.type_expression -> unit -> type_value
-val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value
-val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_value
-val t_record : type_value label_map -> ?s:S.type_expression -> unit -> type_value
-val make_t_ez_record : (label* type_value) list -> type_value 
-(*
-val ez_t_record : ( string * type_value ) list -> ?s:S.type_expression -> unit -> type_value 
-*)
+val t_bool : ?s:S.type_expression -> unit -> type_expression
+val t_string : ?s:S.type_expression -> unit -> type_expression
+val t_bytes : ?s:S.type_expression -> unit -> type_expression
+val t_key : ?s:S.type_expression -> unit -> type_expression
+val t_key_hash : ?s:S.type_expression -> unit -> type_expression
+val t_operation : ?s:S.type_expression -> unit -> type_expression
+val t_timestamp : ?s:S.type_expression -> unit -> type_expression
+val t_set : type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_contract : type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_int : ?s:S.type_expression -> unit -> type_expression
+val t_nat : ?s:S.type_expression -> unit -> type_expression
+val t_mutez : ?s:S.type_expression -> unit -> type_expression
+val t_address : ?s:S.type_expression -> unit -> type_expression
+val t_chain_id : ?s:S.type_expression -> unit -> type_expression
+val t_signature : ?s:S.type_expression -> unit -> type_expression
+val t_unit : ?s:S.type_expression -> unit -> type_expression
+val t_option : type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_pair : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_list  : type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_expression
+val t_record : type_expression label_map -> ?s:S.type_expression -> unit -> type_expression
+val make_t_ez_record : (string* type_expression) list -> type_expression 
+val ez_t_record : ( label * type_expression ) list -> ?s:S.type_expression -> unit -> type_expression 
 
-val t_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
-val t_big_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
-val t_sum : type_value constructor_map -> ?s:S.type_expression -> unit -> type_value
-val make_t_ez_sum : ( constructor * type_value ) list -> type_value
-val t_function : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
-val t_shallow_closure : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
-val get_type_annotation : annotated_expression -> type_value
-val get_type' : type_value -> type_value'
-val get_environment : annotated_expression -> full_environment
-val get_expression : annotated_expression -> expression
+val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression
+val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression
+val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
+val t_shallow_closure : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
+val get_type_expression : expression -> type_expression
+val get_type' : type_expression -> type_content
+val get_environment : expression -> full_environment
+val get_expression : expression -> expression_content
 val get_lambda : expression -> lambda result
-val get_lambda_with_type : annotated_expression -> (lambda * ( type_value * type_value) ) result
-val get_t_bool : type_value -> unit result
+val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result
+val get_t_bool : type_expression -> unit result
 (*
-val get_t_int : type_value -> unit result
-val get_t_nat : type_value -> unit result
-val get_t_unit : type_value -> unit result
-val get_t_mutez : type_value -> unit result
-val get_t_bytes : type_value -> unit result 
-val get_t_string : type_value -> unit result
+val get_t_int : type_expression -> unit result
+val get_t_nat : type_expression -> unit result
+val get_t_unit : type_expression -> unit result
+val get_t_mutez : type_expression -> unit result
+val get_t_bytes : type_expression -> unit result 
+val get_t_string : type_expression -> unit result
 *)
-val get_t_contract : type_value -> type_value result
-val get_t_option : type_value -> type_value result
-val get_t_list : type_value -> type_value result 
-val get_t_set : type_value -> type_value result
+val get_t_contract : type_expression -> type_expression result
+val get_t_option : type_expression -> type_expression result
+val get_t_list : type_expression -> type_expression result 
+val get_t_set : type_expression -> type_expression result
 (*
-val get_t_key : type_value -> unit result
-val get_t_signature : type_value -> unit result
-val get_t_key_hash : type_value -> unit result
+val get_t_key : type_expression -> unit result
+val get_t_signature : type_expression -> unit result
+val get_t_key_hash : type_expression -> unit result
 *)
-val get_t_tuple : type_value -> type_value list result
-val get_t_pair : type_value -> ( type_value * type_value ) result
-val get_t_function : type_value -> ( type_value * type_value ) result
-val get_t_sum : type_value -> type_value constructor_map result
-val get_t_record : type_value -> type_value label_map result
-val get_t_map : type_value -> ( type_value * type_value ) result
-val get_t_big_map : type_value -> ( type_value * type_value ) result
-val get_t_map_key : type_value -> type_value result
-val get_t_map_value : type_value -> type_value result
-val get_t_big_map_key : type_value -> type_value result
-val get_t_big_map_value : type_value -> type_value result
+val get_t_tuple : type_expression -> type_expression list result
+val get_t_pair : type_expression -> ( type_expression * type_expression ) result
+val get_t_function : type_expression -> ( type_expression * type_expression ) result
+val get_t_sum : type_expression -> type_expression constructor_map result
+val get_t_record : type_expression -> type_expression label_map result
+val get_t_map : type_expression -> ( type_expression * type_expression ) result
+val get_t_big_map : type_expression -> ( type_expression * type_expression ) result
+val get_t_map_key : type_expression -> type_expression result
+val get_t_map_value : type_expression -> type_expression result
+val get_t_big_map_key : type_expression -> type_expression result
+val get_t_big_map_value : type_expression -> type_expression result
 
-val assert_t_map : type_value -> unit result
+val assert_t_map : type_expression -> unit result
 
-val is_t_map : type_value -> bool
-val is_t_big_map : type_value -> bool 
+val is_t_map : type_expression -> bool
+val is_t_big_map : type_expression -> bool 
 
-val assert_t_mutez : type_value -> unit result
-val assert_t_key : type_value -> unit result
-val assert_t_signature : type_value -> unit result
-val assert_t_key_hash : type_value -> unit result
+val assert_t_mutez : type_expression -> unit result
+val assert_t_key : type_expression -> unit result
+val assert_t_signature : type_expression -> unit result
+val assert_t_key_hash : type_expression -> unit result
 
-val assert_t_list : type_value -> unit result
+val assert_t_list : type_expression -> unit result
 
-val is_t_list   : type_value -> bool
-val is_t_set    : type_value -> bool
-val is_t_nat    : type_value -> bool
-val is_t_string : type_value -> bool
-val is_t_bytes  : type_value -> bool
-val is_t_int    : type_value -> bool
+val is_t_list   : type_expression -> bool
+val is_t_set    : type_expression -> bool
+val is_t_nat    : type_expression -> bool
+val is_t_string : type_expression -> bool
+val is_t_bytes  : type_expression -> bool
+val is_t_int    : type_expression -> bool
 
-val assert_t_bytes : type_value -> unit result
+val assert_t_bytes : type_expression -> unit result
 (*
-val assert_t_operation : type_value -> unit result
+val assert_t_operation : type_expression -> unit result
 *)
-val assert_t_list_operation : type_value -> unit result
-val assert_t_int : type_value -> unit result
-val assert_t_nat : type_value -> unit result
-val assert_t_bool : type_value -> unit result
-val assert_t_unit : type_value -> unit result
-val assert_t_contract : type_value -> unit result
+val assert_t_list_operation : type_expression -> unit result
+val assert_t_int : type_expression -> unit result
+val assert_t_nat : type_expression -> unit result
+val assert_t_bool : type_expression -> unit result
+val assert_t_unit : type_expression -> unit result
+val assert_t_contract : type_expression -> unit result
 (*
 val e_record : ae_map -> expression
-val ez_e_record : ( string * annotated_expression ) list -> expression
+val ez_e_record : ( string * expression ) list -> expression
 
 *)
-val e_some : value -> expression
-val e_none : unit -> expression
-val e_map : ( value * value ) list -> expression
-val e_unit : unit -> expression
-val e_int : int -> expression
-val e_nat : int -> expression
-val e_mutez : int -> expression
-val e_bool : bool -> expression
-val e_string : string -> expression
-val e_bytes : bytes -> expression
-val e_timestamp : int -> expression
-val e_address : string -> expression
-val e_signature : string -> expression
-val e_key : string -> expression
-val e_key_hash : string -> expression
-val e_chain_id : string -> expression
-val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression
-val e_lambda : lambda -> expression
-val e_pair : value -> value -> expression
-val e_application : value -> value -> expression
-val e_variable : expression_variable -> expression
-val e_list : value list -> expression
-val e_let_in : expression_variable -> inline -> value -> value -> expression
-val e_tuple : value list -> expression
+val e_some : expression -> expression_content
+val e_none : unit -> expression_content
+val e_map : ( expression * expression ) list -> expression_content
+val e_unit : unit -> expression_content
+val e_int : int -> expression_content
+val e_nat : int -> expression_content
+val e_mutez : int -> expression_content
+val e_bool : bool -> expression_content
+val e_string : string -> expression_content
+val e_bytes : bytes -> expression_content
+val e_timestamp : int -> expression_content
+val e_address : string -> expression_content
+val e_signature : string -> expression_content
+val e_key : string -> expression_content
+val e_key_hash : string -> expression_content
+val e_chain_id : string -> expression_content
+val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression_content
+val e_lambda : lambda -> expression_content
+val e_pair : expression -> expression -> expression_content
+val e_application : expression -> expr -> expression_content
+val e_variable : expression_variable -> expression_content
+val e_list : expression list -> expression_content
+val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
 
-val e_a_unit : full_environment -> annotated_expression
-val e_a_int : int -> full_environment -> annotated_expression
-val e_a_nat : int -> full_environment -> annotated_expression
-val e_a_mutez : int -> full_environment -> annotated_expression
-val e_a_bool : bool -> full_environment -> annotated_expression
-val e_a_string : string -> full_environment -> annotated_expression
-val e_a_address : string -> full_environment -> annotated_expression
-val e_a_pair : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
-val e_a_some : annotated_expression -> full_environment -> annotated_expression
-val e_a_lambda : lambda -> type_value -> type_value -> full_environment -> annotated_expression
-val e_a_none : type_value -> full_environment -> annotated_expression
-val e_a_tuple : annotated_expression list -> full_environment -> annotated_expression
-val e_a_record : annotated_expression label_map -> full_environment -> annotated_expression
-val e_a_application : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
-val e_a_variable : expression_variable -> type_value -> full_environment -> annotated_expression
-val ez_e_a_record : ( label * annotated_expression ) list -> full_environment -> annotated_expression
-val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression
-val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression
-val e_a_let_in : expression_variable -> inline -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
+val e_a_unit : full_environment -> expression
+val e_a_int : int -> full_environment -> expression
+val e_a_nat : int -> full_environment -> expression
+val e_a_mutez : int -> full_environment -> expression
+val e_a_bool : bool -> full_environment -> expression
+val e_a_string : string -> full_environment -> expression
+val e_a_address : string -> full_environment -> expression
+val e_a_pair : expression -> expression -> full_environment -> expression
+val e_a_some : expression -> full_environment -> expression
+val e_a_lambda : lambda -> type_expression -> type_expression -> full_environment -> expression
+val e_a_none : type_expression -> full_environment -> expression
+val e_a_record : expression label_map -> full_environment -> expression
+val e_a_application : expression -> expression -> full_environment -> expression
+val e_a_variable : expression_variable -> type_expression -> full_environment -> expression
+val ez_e_a_record : ( label * expression ) list -> full_environment -> expression
+val e_a_map : ( expression * expression ) list -> type_expression -> type_expression -> full_environment -> expression
+val e_a_list : expression list -> type_expression -> full_environment -> expression
+val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression
 
-val get_a_int : annotated_expression -> int result
-val get_a_unit : annotated_expression -> unit result
-val get_a_bool : annotated_expression -> bool result
-val get_a_record_accessor : annotated_expression -> (annotated_expression * label) result
+val get_a_int : expression -> int result
+val get_a_unit : expression -> unit result
+val get_a_bool : expression -> bool result
+val get_a_record_accessor : expression -> (expression * label) result
 val get_declaration_by_name : program -> string -> declaration result

src/stages/ast_typed/combinators_environment.ml

@@ -13,7 +13,6 @@ let e_a_empty_address s = e_a_address s Environment.full_empty
 let e_a_empty_pair a b = e_a_pair a b Environment.full_empty
 let e_a_empty_some s = e_a_some s Environment.full_empty
 let e_a_empty_none t = e_a_none t Environment.full_empty
-let e_a_empty_tuple lst = e_a_tuple lst Environment.full_empty
 let e_a_empty_record r = e_a_record r Environment.full_empty
 let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty
 let e_a_empty_list lst t = e_a_list lst t Environment.full_empty
@@ -24,5 +23,5 @@ open Environment
 
 let env_sum_type ?(env = full_empty)
     ?(type_name = Var.of_name "a_sum_type")
-    (lst : (constructor * type_value) list) =
+    (lst : (constructor' * type_expression) list) =
   add_type type_name (make_t_ez_sum lst) env

src/stages/ast_typed/combinators_environment.mli

@@ -1,22 +1,21 @@
 open Types
 
-val make_a_e_empty : expression -> type_value -> annotated_expression
+val make_a_e_empty : expression_content -> type_expression -> expression
 
-val e_a_empty_unit : annotated_expression
-val e_a_empty_int : int -> annotated_expression
-val e_a_empty_nat : int -> annotated_expression
-val e_a_empty_mutez : int -> annotated_expression
-val e_a_empty_bool : bool -> annotated_expression
-val e_a_empty_string : string -> annotated_expression
-val e_a_empty_address : string -> annotated_expression
-val e_a_empty_pair : annotated_expression -> annotated_expression -> annotated_expression
-val e_a_empty_some : annotated_expression -> annotated_expression
-val e_a_empty_none : type_value -> annotated_expression
-val e_a_empty_tuple : annotated_expression list -> annotated_expression
-val e_a_empty_record : annotated_expression label_map -> annotated_expression
-val e_a_empty_map : (annotated_expression * annotated_expression ) list -> type_value -> type_value -> annotated_expression
-val e_a_empty_list : annotated_expression list -> type_value -> annotated_expression
-val ez_e_a_empty_record : ( label * annotated_expression ) list -> annotated_expression
-val e_a_empty_lambda : lambda -> type_value -> type_value -> annotated_expression
+val e_a_empty_unit : expression
+val e_a_empty_int : int -> expression
+val e_a_empty_nat : int -> expression
+val e_a_empty_mutez : int -> expression
+val e_a_empty_bool : bool -> expression
+val e_a_empty_string : string -> expression
+val e_a_empty_address : string -> expression
+val e_a_empty_pair : expression -> expression -> expression
+val e_a_empty_some : expression -> expression
+val e_a_empty_none : type_expression -> expression
+val e_a_empty_record : expression label_map -> expression
+val e_a_empty_map : (expression * expression ) list -> type_expression -> type_expression -> expression
+val e_a_empty_list : expression list -> type_expression -> expression
+val ez_e_a_empty_record : ( label * expression ) list -> expression
+val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
 
-val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor * type_value) list ->  full_environment
+val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor' * type_expression) list ->  full_environment

src/stages/ast_typed/environment.ml

@@ -1,15 +1,14 @@
 open Types
-open Stage_common.Types
 open Combinators
 
 type element = environment_element
-let make_element : type_value -> full_environment -> environment_element_definition -> element =
+let make_element : type_expression -> full_environment -> environment_element_definition -> element =
   fun type_value source_environment definition -> {type_value ; source_environment ; definition}
 
 let make_element_binder = fun t s -> make_element t s ED_binder
-let make_element_declaration = fun s (ae : annotated_expression) ->
-  let free_variables = Misc.Free_variables.(annotated_expression empty ae) in
-  make_element (get_type_annotation ae) s (ED_declaration (ae , free_variables))
+let make_element_declaration = fun s (ae : expression) ->
+  let free_variables = Misc.Free_variables.(expression empty ae) in
+  make_element (get_type_expression ae) s (ED_declaration (ae , free_variables))
 
 module Small = struct
   type t = small_environment
@@ -22,28 +21,28 @@ module Small = struct
   let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f b)
 
   let add : expression_variable -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x)
-  let add_type : type_variable -> type_value -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
+  let add_type : type_variable -> type_expression -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
   let get_opt : expression_variable -> t -> element option = fun k x -> List.assoc_opt k (get_environment x)
-  let get_type_opt : type_variable -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x)
+  let get_type_opt : type_variable -> t -> type_expression option = fun k x -> List.assoc_opt k (get_type_environment x)
 end
 
 type t = full_environment
 let empty : environment = Small.(get_environment empty)
 let full_empty : t = List.Ne.singleton Small.empty
 let add : expression_variable -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v)
-let add_ez_binder : expression_variable -> type_value -> t -> t = fun k v e ->
+let add_ez_binder : expression_variable -> type_expression -> t -> t = fun k v e ->
   List.Ne.hd_map (Small.add k (make_element_binder v e)) e
-let add_ez_declaration : expression_variable -> annotated_expression -> t -> t = fun k ae e ->
+let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e ->
   List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e
 let add_ez_ae = add_ez_declaration
-let add_type : type_variable -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
+let add_type : type_variable -> type_expression -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
 let get_opt : expression_variable -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
-let get_type_opt : type_variable -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
+let get_type_opt : type_variable -> t -> type_expression option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
 
-let get_constructor : constructor -> t -> (type_value * type_value) option = fun k x -> (* Left is the constructor, right is the sum type *)
+let get_constructor : constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)
   let aux = fun x ->
     let aux = fun (_type_name , x) ->
-      match x.type_value' with
+      match x.type_content with
       | T_sum m ->
         (match CMap.find_opt k m with
            Some km -> Some (km , x)
@@ -56,15 +55,16 @@ let get_constructor : constructor -> t -> (type_value * type_value) option = fun
 
 module PP = struct
   open Format
+  include PP
   open PP_helpers
 
   let list_sep_scope x = list_sep x (const " | ")
 
   let environment_element = fun ppf (k , (ele : environment_element)) ->
-    fprintf ppf "%a -> %a" Stage_common.PP.name k PP.type_value ele.type_value
+    fprintf ppf "%a -> %a" PP.expression_variable k PP.type_expression ele.type_value
 
   let type_environment_element = fun ppf (k , tv) ->
-    fprintf ppf "%a -> %a" Stage_common.PP.type_variable k PP.type_value tv
+    fprintf ppf "%a -> %a" PP.type_variable k PP.type_expression tv
 
   let environment : _ -> environment -> unit = fun ppf lst ->
     fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst
@@ -87,6 +87,6 @@ open Trace
 let get_trace : expression_variable -> t -> element result = fun s env ->
   let error =
     let title () = "missing var not in env" in
-    let content () = Format.asprintf "\nvar: %a\nenv: %a\n" Stage_common.PP.name s PP.full_environment env in
+    let content () = Format.asprintf "\nvar: %a\nenv: %a\n" PP. expression_variable s PP.full_environment env in
     error title content in
   trace_option error @@ get_opt s env

src/stages/ast_typed/environment.mli

@@ -8,13 +8,13 @@ val get_trace : expression_variable -> t -> element result
 val empty : environment
 val full_empty : t
 val add : expression_variable -> element -> t -> t
-val add_ez_binder : expression_variable -> type_value -> t -> t
-val add_ez_declaration : expression_variable -> annotated_expression -> t -> t
-val add_ez_ae : expression_variable -> annotated_expression -> t -> t
-val add_type : type_variable -> type_value -> t -> t
+val add_ez_binder : expression_variable -> type_expression -> t -> t
+val add_ez_declaration : expression_variable -> expression -> t -> t
+val add_ez_ae : expression_variable -> expression -> t -> t
+val add_type : type_variable -> type_expression -> t -> t
 val get_opt : expression_variable -> t -> element option
-val get_type_opt : type_variable -> t -> type_value option
-val get_constructor : constructor -> t -> (type_value * type_value) option
+val get_type_opt : type_variable -> t -> type_expression option
+val get_constructor : constructor' -> t -> (type_expression * type_expression) option
 
 module Small : sig
   type t = small_environment
@@ -28,16 +28,16 @@ module Small : sig
   val map_type_environment : ( type_environment -> type_environment ) -> t -> t
 
   val add : string -> element -> t -> t
-  val add_type : string -> type_value -> t -> t
+  val add_type : string -> type_expression -> t -> t
   val get_opt : string -> t -> element option
-  val get_type_opt : string -> t -> type_value option
+  val get_type_opt : string -> t -> type_expression option
   *)
 end
 (*
 
-val make_element : type_value -> full_environment -> environment_element_definition -> element
-val make_element_binder : type_value -> full_environment -> element
-val make_element_declaration : full_environment -> annotated_expression -> element
+val make_element : type_expression -> full_environment -> environment_element_definition -> element
+val make_element_binder : type_expression -> full_environment -> element
+val make_element_declaration : full_environment -> expression -> element
 *)
 
 
@@ -50,7 +50,7 @@ module PP : sig
 (*
   val environment_element : formatter -> ( string * environment_element ) -> unit
 
-  val type_environment_element : formatter -> ( string * type_value ) -> unit
+  val type_environment_element : formatter -> ( string * type_expression ) -> unit
 
   val environment : formatter -> environment -> unit
 

src/stages/ast_typed/misc.ml

@@ -1,15 +1,13 @@
 open Trace
 open Types
 
-include Stage_common.Misc
-
 module Errors = struct
   let different_kinds a b () =
     let title = (thunk "different kinds") in
     let message () = "" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.type_value b )
+      ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
     ] in
     error ~data title message ()
 
@@ -17,16 +15,16 @@ module Errors = struct
     let title = (thunk "different type constructors") in
     let message () = "Expected these two constant type constructors to be the same, but they're different" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant a) ;
-      ("b" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant b )
+      ("a" , fun () -> Format.asprintf "%a" PP.type_constant a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.type_constant b )
     ] in
     error ~data title message ()
   let different_operators a b () =
     let title = (thunk "different type constructors") in
     let message () = "Expected these two n-ary type constructors to be the same, but they're different" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) a) ;
-      ("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) b)
+      ("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) a) ;
+      ("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) b)
     ] in
     error ~data title message ()
 
@@ -37,44 +35,64 @@ module Errors = struct
                        "Expected these two n-ary type constructors to be the same, but they have different numbers of arguments (both use the %s type constructor, but they have %d and %d arguments, respectively)"
                        (type_operator_name opa) lena lenb in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) opa) ;
-      ("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) opb) ;
+      ("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opa) ;
+      ("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opb) ;
       ("op" , fun () -> type_operator_name opa) ;
       ("len_a" , fun () -> Format.asprintf "%d" lena) ;
       ("len_b" , fun () -> Format.asprintf "%d" lenb) ;
     ] in
     error ~data title message ()
 
-  let different_size_type name a b () =
-    let title () = name ^ " have different sizes" in
-    let message () = "Expected these two types to be the same, but they're different (both are " ^ name ^ ", but with a different number of arguments)" in
+  let different_size_type names a b () =
+    let title () = names ^ " have different sizes" in
+    let message () = "Expected these two types to be the same, but they're different (both are " ^ names ^ ", but with a different number of arguments)" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.type_value b )
+      ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.type_expression b)
     ] in
     error ~data title message ()
 
-  let different_props_in_record ka kb () =
-    let title () = "different keys in record" in
+  let different_props_in_record a b ra rb ka kb () =
+    let names () = if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb then "tuples" else "records" in
+    let title () = "different keys in " ^ (names ()) in
     let message () = "" in
     let data = [
       ("key_a" , fun () -> Format.asprintf "%s" ka) ;
-      ("key_b" , fun () -> Format.asprintf "%s" kb )
+      ("key_b" , fun () -> Format.asprintf "%s" kb ) ;
+      ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) ;
     ] in
     error ~data title message ()
 
+  let different_kind_record_tuple a b ra rb () =
+    let name_a () = if Stage_common.Helpers.is_tuple_lmap ra then "tuple" else "record" in
+    let name_b () = if Stage_common.Helpers.is_tuple_lmap rb then "tuple" else "record" in
+    let title () = "different keys in " ^ (name_a ()) ^ " and " ^ (name_b ()) in
+    let message () = "Expected these two types to be the same, but they're different (one is a " ^ (name_a ()) ^ " and the other is a " ^ (name_b ()) ^ ")" in
+    let data = [
+      ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) ;
+    ] in
+    error ~data title message ()
+
+
   let _different_size_constants = different_size_type "type constructors"
 
   let different_size_sums = different_size_type "sums"
 
-  let different_size_records = different_size_type "records"
+  let different_size_records_tuples a b ra rb =
+    different_size_type
+      (if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb
+       then "tuples"
+       else "records")
+      a b
 
   let different_types name a b () =
     let title () = name ^ " are different" in
     let message () = "Expected these two types to be the same, but they're different" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.type_value b )
+      ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
     ] in
     error ~data title message ()
 
@@ -91,8 +109,8 @@ module Errors = struct
     let title () = name ^ " are different" in
     let message () = "" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.value b )
+      ("a" , fun () -> Format.asprintf "%a"  PP.expression a) ;
+      ("b" , fun () -> Format.asprintf "%a"  PP.expression b )
     ] in
     error ~data title message ()
 
@@ -109,8 +127,8 @@ module Errors = struct
     let title () = "values have different types: " ^ name in
     let message () = "" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.value b )
+      ("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.expression b)
     ] in
     error ~data title message ()
 
@@ -127,8 +145,8 @@ module Errors = struct
     let title () = name ^ " are not comparable" in
     let message () = "" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.value b )
+      ("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
+      ("b" , fun () -> Format.asprintf "%a" PP.expression b )
     ] in
     error ~data title message ()
 
@@ -136,8 +154,8 @@ module Errors = struct
     let title () = name in
     let message () = "" in
     let data = [
-      ("a" , fun () -> Format.asprintf "%a" PP.value a) ;
-      ("b" , fun () -> Format.asprintf "%a" PP.value b )
+      ("a" , fun () -> Format.asprintf "%a"  PP.expression a) ;
+      ("b" , fun () -> Format.asprintf "%a"  PP.expression b )
     ] in
     error ~data title message ()
 
@@ -177,49 +195,45 @@ module Free_variables = struct
   let empty : bindings = []
   let of_list : expression_variable list -> bindings = fun x -> x
 
-  let rec expression : bindings -> expression -> bindings = fun b e ->
-    let self = annotated_expression b in
-    match e with
+  let rec expression_content : bindings -> expression_content -> bindings = fun b ec ->
+    let self = expression b in
+    match ec with
     | E_lambda l -> lambda b l
     | E_literal _ -> empty
-    | E_constant (_ , lst) -> unions @@ List.map self lst
+    | E_constant {arguments;_} -> unions @@ List.map self arguments
     | E_variable name -> (
         match mem name b with
         | true -> empty
         | false -> singleton name
       )
-    | E_application (a, b) -> unions @@ List.map self [ a ; b ]
-    | E_tuple lst -> unions @@ List.map self lst
-    | E_constructor (_ , a) -> self a
+    | E_application {expr1;expr2} -> unions @@ List.map self [ expr1 ; expr2 ]
+    | E_constructor {element;_} -> self element
     | E_record m -> unions @@ List.map self @@ LMap.to_list m
-    | E_record_accessor (a, _) -> self a
-    | E_record_update (r,(_,e)) -> union (self r) @@ self e
-    | E_tuple_accessor (a, _) -> self a
+    | E_record_accessor {expr;_} -> self expr
+    | E_record_update {record; update;_} -> union (self record) @@ self update
     | E_list lst -> unions @@ List.map self lst
     | E_set lst -> unions @@ List.map self lst
     | (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
     | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
-    | E_matching (a , cs) -> union (self a) (matching_expression b cs)
-    | E_sequence (a , b) -> unions @@ List.map self [ a ; b ]
-    | E_loop (expr , body) -> unions @@ List.map self [ expr ; body ]
-    | E_assign (_ , _ , expr) -> self expr
-    | E_let_in { binder; rhs; result; _ } ->
-      let b' = union (singleton binder) b in
+    | E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
+    | E_loop {condition ; body} -> unions @@ List.map self [ condition ; body ]
+    | E_let_in { let_binder; rhs; let_result; _} ->
+      let b' = union (singleton let_binder) b in
       union
-        (annotated_expression b' result)
-        (annotated_expression b rhs)
+        (expression b' let_result)
+        (self rhs)
 
   and lambda : bindings -> lambda -> bindings = fun b l ->
     let b' = union (singleton l.binder) b in
-    annotated_expression b' l.body
+    expression b' l.result
 
-  and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
-    expression b ae.expression
+  and expression : bindings -> expression -> bindings = fun b e ->
+    expression_content b e.expression_content
 
-  and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor * expression_variable) * a) -> bindings  = fun f b ((_,n),c) ->
+  and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor' * expression_variable) * a) -> bindings  = fun f b ((_,n),c) ->
     f (union (singleton n) b) c
 
-  and matching : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching -> bindings = fun f b m ->
+  and matching : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching_content -> bindings = fun f b m ->
     match m with
     | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
     | Match_list { match_nil = n ; match_cons = (hd, tl, c, _) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
@@ -228,7 +242,7 @@ module Free_variables = struct
        f (union (of_list lst) b) a    
     | Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst
 
-  and matching_expression = fun x -> matching annotated_expression x
+  and matching_expression = fun x -> matching expression x
 
 end
 
@@ -314,7 +328,7 @@ end
 open Errors
 
        
-let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with
+let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : unit result = match (a.type_content, b.type_content) with
   | T_constant ca, T_constant cb -> (
       trace_strong (different_constants ca cb)
       @@ Assert.assert_true (ca = cb)
@@ -328,16 +342,14 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
       | TC_set la, TC_set lb -> ok @@ ([la], [lb])
       | TC_map (ka,va), TC_map (kb,vb)
       | TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb]) 
-      | TC_tuple lsta, TC_tuple lstb -> ok @@ (lsta , lstb) 
-      | TC_arrow (froma , toa) , TC_arrow (fromb , tob) -> ok @@ ([froma;toa] , [fromb;tob]) 
-      | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_tuple _ | TC_arrow _),
-        (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_tuple _ | TC_arrow _) -> fail @@ different_operators opa opb
+      | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _),
+        (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb
       in
       if List.length lsta <> List.length lstb then
         fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
       else
         trace (different_types "arguments to type operators" a b)
-        @@ bind_list_iter (fun (a,b) -> assert_type_value_eq (a,b) )(List.combine lsta lstb)
+        @@ bind_list_iter (fun (a,b) -> assert_type_expression_eq (a,b) )(List.combine lsta lstb)
   )
   | T_operator _, _ -> fail @@ different_kinds a b
   | T_sum sa, T_sum sb -> (
@@ -347,7 +359,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
         let%bind _ =
           Assert.assert_true ~msg:"different keys in sum types"
           @@ (ka = kb) in
-        assert_type_value_eq (va, vb)
+        assert_type_expression_eq (va, vb)
       in
       let%bind _ =
         trace_strong (different_size_sums a b)
@@ -356,36 +368,41 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
       bind_list_iter aux (List.combine sa' sb')
     )
   | T_sum _, _ -> fail @@ different_kinds a b
+  | T_record ra, T_record rb
+       when Stage_common.Helpers.is_tuple_lmap ra <> Stage_common.Helpers.is_tuple_lmap rb -> (
+    fail @@ different_kind_record_tuple a b ra rb
+  )
   | T_record ra, T_record rb -> (
-      let ra' = LMap.to_kv_list ra in
-      let rb' = LMap.to_kv_list rb in
+      let sort_lmap r' = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) r' in
+      let ra' = sort_lmap @@ LMap.to_kv_list ra in
+      let rb' = sort_lmap @@ LMap.to_kv_list rb in
       let aux ((ka, va), (kb, vb)) =
         let%bind _ =
           trace (different_types "records" a b) @@
           let Label ka = ka in
           let Label kb = kb in
-          trace_strong (different_props_in_record ka kb) @@
+          trace_strong (different_props_in_record a b ra rb ka kb) @@
           Assert.assert_true (ka = kb) in
-        assert_type_value_eq (va, vb)
+        assert_type_expression_eq (va, vb)
       in
       let%bind _ =
-        trace_strong (different_size_records a b)
+        trace_strong (different_size_records_tuples a b ra rb)
         @@ Assert.assert_list_same_size ra' rb' in
       trace (different_types "record type" a b)
       @@ bind_list_iter aux (List.combine ra' rb')
 
     )
   | T_record _, _ -> fail @@ different_kinds a b
-  | T_arrow (param, result), T_arrow (param', result') ->
-      let%bind _ = assert_type_value_eq (param, param') in
-      let%bind _ = assert_type_value_eq (result, result') in
+  | T_arrow {type1;type2}, T_arrow {type1=type1';type2=type2'} ->
+      let%bind _ = assert_type_expression_eq (type1, type1') in
+      let%bind _ = assert_type_expression_eq (type2, type2') in
       ok ()
   | T_arrow _, _ -> fail @@ different_kinds a b
   | T_variable x, T_variable y -> let _ = (x = y) in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding"
   | T_variable _, _ -> fail @@ different_kinds a b
 
 (* No information about what made it fail *)
-let type_value_eq ab = Trace.to_bool @@ assert_type_value_eq ab
+let type_expression_eq ab = Trace.to_bool @@ assert_type_expression_eq ab
 
 let assert_literal_eq (a, b : literal * literal) : unit result =
   match (a, b) with
@@ -410,6 +427,8 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
   | Literal_bytes a, Literal_bytes b when a = b -> ok ()
   | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytes" a b
   | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
+  | Literal_void, Literal_void -> ok ()
+  | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
   | Literal_unit, Literal_unit -> ok ()
   | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
   | Literal_address a, Literal_address b when a = b -> ok ()
@@ -431,15 +450,15 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
   | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
 
 
-let rec assert_value_eq (a, b: (value*value)) : unit result =
+let rec assert_value_eq (a, b: (expression*expression)) : unit result =
   let error_content () =
-    Format.asprintf "\n%a vs %a" PP.value a PP.value b
+    Format.asprintf "\n%a vs %a" PP.expression a PP.expression b
   in
   trace (fun () -> error (thunk "not equal") error_content ()) @@
-  match (a.expression, b.expression) with
+  match (a.expression_content, b.expression_content) with
   | E_literal a, E_literal b ->
       assert_literal_eq (a, b)
-  | E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> (
+  | E_constant {cons_name=ca;arguments=lsta}, E_constant {cons_name=cb;arguments=lstb} when ca = cb -> (
       let%bind lst =
         generic_try (different_size_values "constants with different number of elements" a b)
           (fun () -> List.combine lsta lstb) in
@@ -451,12 +470,12 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
   | E_constant _, _ ->
       let error_content () =
         Format.asprintf "%a vs %a"
-          PP.annotated_expression a
-          PP.annotated_expression b
+          PP.expression a
+          PP.expression b
       in
       fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ())
 
-  | E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
+  | E_constructor {constructor=ca;element=a}, E_constructor {constructor=cb;element=b} when ca = cb -> (
       let%bind _eq = assert_value_eq (a, b) in
       ok ()
     )
@@ -464,24 +483,13 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
       fail @@ different_values "constructors" a b
   | E_constructor _, _ ->
       fail @@ different_values_because_different_types "constructor vs. non-constructor" a b
-
-  | E_tuple lsta, E_tuple lstb -> (
-      let%bind lst =
-        generic_try (different_size_values "tuples with different number of elements" a b)
-          (fun () -> List.combine lsta lstb) in
-      let%bind _all = bind_list @@ List.map assert_value_eq lst in
-      ok ()
-    )
-  | E_tuple _, _ ->
-      fail @@ different_values_because_different_types "tuple vs. non-tuple" a b
-
   | E_record sma, E_record smb -> (
       let aux (Label k) a b =
         match a, b with
         | Some a, Some b -> Some (assert_value_eq (a, b))
         | _              -> Some (fail @@ missing_key_in_record_value k)
       in
-      let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
+      let%bind _all = Stage_common.Helpers.bind_lmap @@ LMap.merge aux sma smb in
       ok ()
     )
   | E_record _, _ ->
@@ -522,30 +530,28 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
   | E_set _, _ ->
       fail @@ different_values_because_different_types "set vs. non-set" a b
   | (E_literal _, _) | (E_variable _, _) | (E_application _, _)
-  | (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _)
-  | (E_record_update _,_)
-  | (E_record_accessor _, _)
+  | (E_lambda _, _) | (E_let_in _, _)
+  | (E_record_accessor _, _) | (E_record_update _,_)
   | (E_look_up _, _) | (E_matching _, _)
-  | (E_assign _ , _)
-  | (E_sequence _, _) | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
+  | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
 
-let merge_annotation (a:type_value option) (b:type_value option) err : type_value result =
+let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =
   match a, b with
   | None, None -> fail @@ err
   | Some a, None -> ok a
   | None, Some b -> ok b
   | Some a, Some b ->
-      let%bind _ = assert_type_value_eq (a, b) in
-      match a.simplified, b.simplified with
+      let%bind _ = assert_type_expression_eq (a, b) in
+      match a.type_meta, b.type_meta with
       | _, None -> ok a
       | _, Some _ -> ok b
 
-let get_entry (lst : program) (name : string) : annotated_expression result =
+let get_entry (lst : program) (name : string) : expression result =
   trace_option (Errors.missing_entry_point name) @@
   let aux x =
-    let (Declaration_constant (an , _, _)) = Location.unwrap x in
-    if (an.name = Var.of_name name)
-    then Some an.annotated_expression
+    let (Declaration_constant (an , expr, _, _)) = Location.unwrap x in
+    if (an = Var.of_name name)
+    then Some expr
     else None
   in
   List.find_map aux lst
@@ -553,4 +559,4 @@ let get_entry (lst : program) (name : string) : annotated_expression result =
 let program_environment (program : program) : full_environment =
   let last_declaration = Location.unwrap List.(hd @@ rev program) in
   match last_declaration with
-  | Declaration_constant (_ , _, (_ , post_env)) -> post_env
+  | Declaration_constant (_ , _, _, post_env) -> post_env

src/stages/ast_typed/misc.mli

@@ -1,16 +1,14 @@
 open Trace
 open Types
 
-include module type of Stage_common.Misc
+val assert_value_eq : ( expression * expression ) -> unit result
 
-val assert_value_eq : ( value * value ) -> unit result
+val assert_type_expression_eq : ( type_expression * type_expression ) -> unit result
 
-val assert_type_value_eq : ( type_value * type_value ) -> unit result
-
-val merge_annotation : type_value option -> type_value option -> error_thunk -> type_value result
+val merge_annotation : type_expression option -> type_expression option -> error_thunk -> type_expression result
 
 (* No information about what made it fail *)
-val type_value_eq : ( type_value * type_value ) -> bool
+val type_expression_eq : ( type_expression * type_expression ) -> bool
 
 module Free_variables : sig
   type bindings = expression_variable list
@@ -18,7 +16,7 @@ module Free_variables : sig
   val matching_expression : bindings -> matching_expr -> bindings
   val lambda : bindings -> lambda -> bindings
 
-  val annotated_expression : bindings -> annotated_expression -> bindings 
+  val expression : bindings -> expression -> bindings 
 
   val empty : bindings 
   val singleton : expression_variable -> bindings 
@@ -40,14 +38,16 @@ end
 
 module Errors : sig
   (*
-  val different_kinds : type_value -> type_value -> unit -> error
+  val different_kinds : type_expression -> type_expression -> unit -> error
   val different_constants : string -> string -> unit -> error
-  val different_size_type : name -> type_value -> type_value -> unit -> error
+  val different_size_type : name -> type_expression -> type_expression -> unit -> error
   val different_props_in_record : string -> string -> unit -> error
-  val different_size_constants : type_value -> type_value -> unit -> error
-  val different_size_sums : type_value -> type_value -> unit -> error
-  val different_size_records : type_value -> type_value -> unit -> error
-  val different_types : name -> type_value -> type_value -> unit -> error
+  val different_size_constants : type_expression -> type_expression -> unit -> error
+  val different_size_tuples : type_expression -> type_expression -> unit -> error
+  val different_size_sums : type_expression -> type_expression -> unit -> error
+  val different_size_records : type_expression -> type_expression -> unit -> error
+  val different_size_tuples : type_expression -> type_expression -> unit -> error
+  val different_types : name -> type_expression -> type_expression -> unit -> error
   val different_literals : name -> literal -> literal -> unit -> error
   val different_values : name -> value -> value -> unit -> error
   val different_literals_because_different_types : name -> literal -> literal -> unit -> error
@@ -67,5 +67,5 @@ end
 val assert_literal_eq : ( literal * literal ) -> unit result
 *)
 
-val get_entry : program -> string -> annotated_expression result
+val get_entry : program -> string -> expression result
 val program_environment : program -> full_environment

src/stages/ast_typed/misc_smart.ml

@@ -8,31 +8,31 @@ let program_to_main : program -> string -> lambda result = fun p s ->
   let%bind (main , input_type , _) =
     let pred = fun d ->
       match d with
-      | Declaration_constant (d , _, _) when d.name = Var.of_name s -> Some d.annotated_expression
+      | Declaration_constant (d , expr, _, _) when d = Var.of_name s -> Some expr
       | Declaration_constant _ -> None
     in
     let%bind main =
       trace_option (simple_error "no main with given name") @@
       List.find_map (Function.compose pred Location.unwrap) p in
     let%bind (input_ty , output_ty) =
-      match (get_type' @@ get_type_annotation main) with
-      | T_arrow (i , o) -> ok (i , o)
+      match (get_type' @@ get_type_expression main) with
+      | T_arrow {type1;type2} -> ok (type1 , type2)
       | _ -> simple_fail "program main isn't a function" in
     ok (main , input_ty , output_ty)
   in
   let env =
     let aux = fun _ d ->
       match d with
-      | Declaration_constant (_ , _, (_ , post_env)) -> post_env in
+      | Declaration_constant (_ , _, _, post_env) -> post_env in
     List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
   let binder = Var.of_name "@contract_input" in
-  let body =
+  let result =
     let input_expr = e_a_variable binder input_type env in
-    let main_expr = e_a_variable (Var.of_name s) (get_type_annotation main) env in
+    let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in
     e_a_application main_expr input_expr env in
   ok {
     binder ;
-    body ;
+    result ;
   }
 
 module Captured_variables = struct
@@ -45,13 +45,13 @@ module Captured_variables = struct
   let empty : bindings = []
   let of_list : expression_variable list -> bindings = fun x -> x
 
-  let rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae ->
-    let self = annotated_expression b in
-    match ae.expression with
+  let rec expression : bindings -> expression -> bindings result = fun b ae ->
+    let self = expression b in
+    match ae.expression_content with
     | E_lambda l -> ok @@ Free_variables.lambda empty l
     | E_literal _ -> ok empty
-    | E_constant (_ , lst) ->
-      let%bind lst' = bind_map_list self lst in
+    | E_constant {arguments;_} ->
+      let%bind lst' = bind_map_list self arguments in
       ok @@ unions lst'
     | E_variable name -> (
         let%bind env_element =
@@ -61,22 +61,18 @@ module Captured_variables = struct
         | ED_binder -> ok empty
         | ED_declaration (_ , _) -> simple_fail "todo"
       )
-    | E_application (a, b) ->
-      let%bind lst' = bind_map_list self [ a ; b ] in
+    | E_application {expr1;expr2} ->
+      let%bind lst' = bind_map_list self [ expr1 ; expr2 ] in
       ok @@ unions lst'
-    | E_tuple lst ->
-      let%bind lst' = bind_map_list self lst in
-      ok @@ unions lst'
-    | E_constructor (_ , a) -> self a
+    | E_constructor {element;_} -> self element
     | E_record m ->
       let%bind lst' = bind_map_list self @@ LMap.to_list m in
       ok @@ unions lst'
-    | E_record_accessor (a, _) -> self a
-    | E_record_update (r,(_,e)) -> 
-      let%bind r = self r in
-      let%bind e = self e in
+    | E_record_accessor {expr;_} -> self expr
+    | E_record_update {record;update;_} -> 
+      let%bind r = self record in
+      let%bind e = self update in
       ok @@ union r e
-    | E_tuple_accessor (a, _) -> self a
     | E_list lst ->
       let%bind lst' = bind_map_list self lst in
       ok @@ unions lst'
@@ -89,23 +85,21 @@ module Captured_variables = struct
     | E_look_up (a , b) ->
       let%bind lst' = bind_map_list self [ a ; b ] in
       ok @@ unions lst'
-    | E_matching (a , cs) ->
-      let%bind a' = self a in
-      let%bind cs' = matching_expression b cs in
+    | E_matching {matchee;cases;_} ->
+      let%bind a' = self matchee in
+      let%bind cs' = matching_expression b cases in
       ok @@ union a' cs'
-    | E_sequence (_ , b) -> self b
-    | E_loop (expr , body) ->
-      let%bind lst' = bind_map_list self [ expr ; body ] in
+    | E_loop {condition; body} ->
+      let%bind lst' = bind_map_list self [ condition ; body ] in
       ok @@ unions lst'
-    | E_assign (_ , _ , expr) -> self expr
     | E_let_in li ->
-      let b' = union (singleton li.binder) b in
-      annotated_expression b' li.result
+      let b' = union (singleton li.let_binder) b in
+      expression b' li.let_result
 
-  and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor * expression_variable) * a) -> bindings result  = fun f b ((_,n),c) ->
+  and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor' * expression_variable) * a) -> bindings result  = fun f b ((_,n),c) ->
     f (union (singleton n) b) c
 
-  and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching -> bindings result = fun f b m ->
+  and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching_content -> bindings result = fun f b m ->
     match m with
     | Match_bool { match_true = t ; match_false = fa } ->
       let%bind t' = f b t in
@@ -125,6 +119,6 @@ module Captured_variables = struct
       let%bind lst' = bind_map_list (matching_variant_case f b) lst in
       ok @@ unions lst'
 
-  and matching_expression = fun x -> matching annotated_expression x
+  and matching_expression = fun x -> matching expression x
 
 end

src/stages/ast_typed/misc_smart.mli

@@ -1,13 +1,12 @@
 open Trace
 open Types
-open Stage_common.Types
 
 val program_to_main : program -> string -> lambda result
 
 module Captured_variables : sig
 
   type bindings = expression_variable list
-  val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_value) matching -> bindings result
+  val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_expression) matching_content -> bindings result
 
   val matching_expression : bindings -> matching_expr -> bindings result
 

src/stages/ast_typed/types.ml

@@ -3,6 +3,12 @@
 module S = Ast_simplified
 include Stage_common.Types
 
+module Ast_typed_type_parameter = struct
+  type type_meta = S.type_expression option
+end
+
+include Ast_generic_type (Ast_typed_type_parameter)
+
 type program = declaration Location.wrap list
 
 and inline = bool
@@ -13,105 +19,108 @@ and declaration =
    *   a boolean indicating whether it should be inlined
    *   the environment before the declaration (the original environment)
    *   the environment after the declaration (i.e. with that new declaration added to the original environment). *)
-  | Declaration_constant of (named_expression * inline * (full_environment * full_environment))
+  | Declaration_constant of (expression_variable * expression * inline * full_environment)
+  (*
+  | Declaration_type of (type_variable * type_expression)
+  | Declaration_constant of (named_expression * (full_environment * full_environment))
+  *)
+(* | Macro_declaration of macro_declaration *)
+
+and expression =
+  { expression_content: expression_content
+  ; location: Location.t
+  ; type_expression: type_expression
+  ; environment: full_environment }
+
+and expression_content =
+  (* Base *)
+  | E_literal of literal
+  | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_variable of expression_variable
+  | E_application of application
+  | E_lambda of lambda
+  | E_let_in of let_in
+  (* Variant *)
+  | E_constructor of constructor (* For user defined constructors *)
+  | E_matching of matching
+  (* Record *)
+  | E_record of expression label_map
+  | E_record_accessor of accessor
+  | E_record_update of update
+  (* Data Structures *)
+  (* TODO : move to constant*)
+  | E_map of (expression * expression) list (*move to operator *)
+  | E_big_map of (expression * expression) list (*move to operator *)
+  | E_list of expression list
+  | E_set of expression list
+  | E_look_up of (expression * expression)
+  (* Advanced *)
+  | E_loop of loop
+  (*
+  | E_ascription of ascription
+  *)
+
+and constant =
+  { cons_name: constant' (* this is at the end because it is huge *)
+  ; arguments: expression list }
+
+
+and application = {expr1: expression; expr2: expression}
+
+and lambda =
+  { binder: expression_variable 
+ (* ; input_type: type_expression option
+  ; output_type: type_expression option *)
+  ; result: expression }
+
+and let_in =
+  { let_binder: expression_variable
+  ; rhs: expression
+  ; let_result: expression
+  ; inline : inline }
+
+and constructor = {constructor: constructor'; element: expression}
+
+and accessor = {expr: expression; label: label}
+
+and update = {record: expression; path: label ; update: expression}
+
+and loop = {condition: expression; body: expression}
+
+and matching_expr = (expression,type_expression) matching_content
+and matching =
+  { matchee: expression
+  ; cases: matching_expr
+  }
+
+and ascription = {anno_expr: expression; type_annotation: type_expression}
+
 
 and environment_element_definition =
   | ED_binder
-  | ED_declaration of (annotated_expression * free_variables)
+  | ED_declaration of (expression * free_variables)
 
 and free_variables = expression_variable list
 
-and environment_element = {
-  type_value : type_value ;
-  source_environment : full_environment ;
-  definition : environment_element_definition ;
-}
+and environment_element =
+  { type_value: type_expression
+  ; source_environment: full_environment
+  ; definition: environment_element_definition }
+
 and environment = (expression_variable * environment_element) list
-and type_environment = (type_variable * type_value) list (* SUBST ??? *)
-and small_environment = (environment * type_environment)
+
+and type_environment = (type_variable * type_expression) list
+
+(* SUBST ??? *)
+and small_environment = environment * type_environment
+
 and full_environment = small_environment List.Ne.t
 
-and annotated_expression = {
-  expression : expression ;
-  type_annotation : type_value ;        (* SUBST *)
-  environment : full_environment ;
-  location : Location.t ;
+and expr = expression
+
+and texpr = type_expression
+
+and named_type_content = {
+    type_name : type_variable;
+    type_value : type_expression;
 }
-
-(* This seems to be used only for top-level declarations, and
-   represents the name of the top-level binding, and the expression
-   assigned to it. -- Suzanne.
-
-   TODO: if this is correct, then we should inline this in
-   "declaration" or at least move it close to it. *)
-and named_expression = {
-  name: expression_variable ;
-  annotated_expression: ae ;
-}
-
-and ae = annotated_expression
-and type_value' = type_value type_expression'
-
-and type_value = {
-  type_value' : type_value';
-  simplified : S.type_expression option ; (* If we have the simplified this AST fragment comes from, it is stored here, for easier untyping. *)
-}
-
-(* This is used in E_assign of (named_type_value * access_path * ae).
-   In mini_c, we need the type associated with `x` in the assignment
-   expression `x.y.z := 42`, so it is stored here. *)
-and named_type_value = {
-  type_name: expression_variable ;
-  type_value : type_value ;
-}
-
-(* E_lamba and other expressions are always wrapped as an annotated_expression. *)
-and lambda = {
-  binder : expression_variable ;
-  (* input_type: tv ;
-   * output_type: tv ; *)
-  body : ae ;
-}
-
-and let_in = {
-  binder: expression_variable;
-  rhs: ae;
-  result: ae;
-  inline: inline;
-}
-
-and 'a expression' =
-  (* Base *)
-  | E_literal of literal
-  | E_constant of (constant * ('a) list) (* For language constants, like (Cons hd tl) or (plus i j) *)
-  | E_variable of expression_variable
-  | E_application of (('a) * ('a))
-  | E_lambda of lambda
-  | E_let_in of let_in
-  (* Tuple, TODO: remove tuples and use records with integer keys instead *)
-  | E_tuple of ('a) list
-  | E_tuple_accessor of (('a) * int) (* Access n'th tuple's element *)
-  (* Sum *)
-  | E_constructor of (constructor * ('a)) (* For user defined constructors *)
-  (* Record *)
-  | E_record of ('a) label_map
-  | E_record_accessor of (('a) * label)
-  | E_record_update of ('a * (label * 'a))
-  (* Data Structures *)
-  | E_map of (('a) * ('a)) list
-  | E_big_map of (('a) * ('a)) list
-  | E_list of ('a) list
-  | E_set of ('a) list
-  | E_look_up of (('a) * ('a))
-  (* Advanced *)
-  | E_matching of (('a) * matching_expr)
-  (* Replace Statements *)
-  | E_sequence of (('a) * ('a))
-  | E_loop of (('a) * ('a))
-  | E_assign of (named_type_value * access_path * ('a))
- 
-and expression = ae expression'
-
-and value = annotated_expression (* todo (for refactoring) *)
-
-and matching_expr = (ae,type_value) matching

src/stages/common/PP.ml

@@ -2,19 +2,45 @@ open Types
 open Format
 open PP_helpers
 
-let name ppf (n:expression_variable) : unit = 
-  fprintf ppf "%a" Var.pp n
-
-let type_variable ppf (t:type_variable) : unit =
-  fprintf ppf "%a" Var.pp t
-
-let constructor ppf (c:constructor) : unit =
+let constructor ppf (c:constructor') : unit =
   let Constructor c = c in fprintf ppf "%s" c
 
 let label ppf (l:label) : unit =
   let Label l = l in fprintf ppf "%s" l
 
-let constant ppf : constant -> unit = function
+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 "%a -> %a" constructor k value v in
+  fprintf ppf "%a" (list_sep new_pp sep) lst
+
+let record_sep value sep ppf (m : 'a label_map) =
+  let lst = LMap.to_kv_list m in
+  let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
+  let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
+  fprintf ppf "%a" (list_sep new_pp sep) lst
+
+let tuple_sep value sep ppf m =
+  assert (Helpers.is_tuple_lmap m);
+  let lst = LMap.to_kv_list m in
+  let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
+  let new_pp ppf (_k, v) = fprintf ppf "%a" value v in
+  fprintf ppf "%a" (list_sep new_pp sep) lst
+
+(* Prints records which only contain the consecutive fields
+   0..(cardinal-1) as tuples *)
+let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m =
+  if Helpers.is_tuple_lmap m then
+    fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m
+  else
+    fprintf ppf format_record (record_sep value (const sep_record)) m
+
+let list_sep_d x = list_sep x (const " , ")
+let cmap_sep_d x = cmap_sep x (const " , ")
+let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , "
+let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * "
+
+let constant ppf : constant' -> unit = function
   | C_INT                   -> fprintf ppf "INT"
   | C_UNIT                  -> fprintf ppf "UNIT"
   | C_NIL                   -> fprintf ppf "NIL"
@@ -84,6 +110,8 @@ let constant ppf : constant -> unit = function
   | C_MAP                   -> fprintf ppf "MAP"
   | C_MAP_EMPTY             -> fprintf ppf "MAP_EMPTY"
   | C_MAP_LITERAL           -> fprintf ppf "MAP_LITERAL"
+  | C_MAP_GET               -> fprintf ppf "MAP_GET"
+  | C_MAP_GET_FORCE         -> fprintf ppf "MAP_GET_FORCE"
   | C_MAP_ADD               -> fprintf ppf "MAP_ADD"
   | C_MAP_REMOVE            -> fprintf ppf "MAP_REMOVE"
   | C_MAP_UPDATE            -> fprintf ppf "MAP_UPDATE"
@@ -101,6 +129,7 @@ let constant ppf : constant -> unit = function
   | C_SHA256                -> fprintf ppf "SHA256"
   | C_SHA512                -> fprintf ppf "SHA512"
   | C_BLAKE2b               -> fprintf ppf "BLAKE2b"
+  | C_HASH                  -> fprintf ppf "HASH"
   | C_HASH_KEY              -> fprintf ppf "HASH_KEY"
   | C_CHECK_SIGNATURE       -> fprintf ppf "CHECK_SIGNATURE"
   | C_CHAIN_ID              -> fprintf ppf "CHAIN_ID"
@@ -120,85 +149,119 @@ let constant ppf : constant -> unit = function
   | C_SET_DELEGATE          -> fprintf ppf "SET_DELEGATE"
   | C_STEPS_TO_QUOTA        -> fprintf ppf "STEPS_TO_QUOTA"
 
-let cmap_sep value sep ppf m =
-  let lst = Types.CMap.to_kv_list m in
-  let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in
-  fprintf ppf "%a" (list_sep new_pp sep) lst
+let literal ppf (l : literal) =
+  match l with
+  | Literal_unit ->
+      fprintf ppf "unit"
+  | Literal_void ->
+      fprintf ppf "void"
+  | Literal_bool b ->
+      fprintf ppf "%b" b
+  | Literal_int n ->
+      fprintf ppf "%d" n
+  | Literal_nat n ->
+      fprintf ppf "+%d" n
+  | Literal_timestamp n ->
+      fprintf ppf "+%d" n
+  | Literal_mutez n ->
+      fprintf ppf "%dmutez" n
+  | Literal_string s ->
+      fprintf ppf "%S" s
+  | Literal_bytes b ->
+      fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
+  | Literal_address s ->
+      fprintf ppf "@%S" s
+  | Literal_operation _ ->
+      fprintf ppf "Operation(...bytes)"
+  | Literal_key s ->
+      fprintf ppf "key %s" s
+  | Literal_key_hash s ->
+      fprintf ppf "key_hash %s" s
+  | Literal_signature s ->
+      fprintf ppf "Signature %s" s
+  | Literal_chain_id s ->
+      fprintf ppf "Chain_id %s" s
+module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
+  module Agt=Ast_generic_type(PARAMETER)
+  open Agt
+  open Format
 
-let lmap_sep value sep ppf m =
-  let lst = Types.LMap.to_kv_list m in
-  let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
-  fprintf ppf "%a" (list_sep new_pp sep) lst
+  let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
 
-let lrecord_sep value sep ppf m =
-  let lst = Types.LMap.to_kv_list m in
-  let new_pp ppf (k, v) = fprintf ppf "%a = %a" label k value v in
-  fprintf ppf "%a" (list_sep new_pp sep) lst
-
-let list_sep_d x = list_sep x (const " , ")
-let cmap_sep_d x = cmap_sep x (const " , ")
-let lmap_sep_d x = lmap_sep x (const " , ")
-
-let rec type_expression' : type a . (formatter -> a -> unit) -> formatter -> a type_expression' -> unit =
+  let rec type_expression' :
+         (formatter -> type_expression -> unit)
+      -> formatter
+      -> type_expression
+      -> unit =
    fun f ppf te ->
-  match te with
-    | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
-    | T_record m -> fprintf ppf "record[%a]" (lmap_sep_d f ) m
-    | T_arrow (a, b) -> fprintf ppf "%a -> %a" f a f b
-    | T_variable tv -> type_variable ppf tv
-    | T_constant tc -> type_constant ppf tc
-    | T_operator to_ -> type_operator f ppf to_
+    match te.type_content with
+    | T_sum m ->
+        fprintf ppf "sum[%a]" (cmap_sep_d f) m
+    | T_record m ->
+        fprintf ppf "%a" (tuple_or_record_sep_type f) m
+    | T_arrow a ->
+        fprintf ppf "%a -> %a" f a.type1 f a.type2
+    | T_variable tv ->
+        type_variable ppf tv
+    | T_constant tc ->
+        type_constant ppf tc
+    | T_operator to_ ->
+        type_operator f ppf to_
 
-and type_constant ppf (tc:type_constant) : unit =
-  let s = match tc with
-    | TC_unit      -> "unit"
-    | TC_string    -> "string"
-    | TC_bytes     -> "bytes"
-    | TC_nat       -> "nat"
-    | TC_int       -> "int"
-    | TC_mutez     -> "mutez"
-    | TC_bool      -> "bool"
-    | TC_operation -> "operation"
-    | TC_address   -> "address"
-    | TC_key       -> "key"
-    | TC_key_hash  -> "key_hash"
-    | TC_signature -> "signature"
-    | TC_timestamp -> "timestamp"
-    | TC_chain_id  -> "chain_id"
+  and type_expression ppf (te : type_expression) : unit =
+    type_expression' type_expression ppf te
+
+  and type_constant ppf (tc : type_constant) : unit =
+    let s =
+      match tc with
+      | TC_unit ->
+          "unit"
+      | TC_string ->
+          "string"
+      | TC_bytes ->
+          "bytes"
+      | TC_nat ->
+          "nat"
+      | TC_int ->
+          "int"
+      | TC_mutez ->
+          "mutez"
+      | TC_bool ->
+          "bool"
+      | TC_operation ->
+          "operation"
+      | TC_address ->
+          "address"
+      | TC_key ->
+          "key"
+      | TC_key_hash ->
+          "key_hash"
+      | TC_signature ->
+          "signatuer"
+      | TC_timestamp ->
+          "timestamp"
+      | TC_chain_id ->
+          "chain_id"
+      | TC_void ->
+          "void"
     in
     fprintf ppf "%s" s
 
-
-and type_operator : type a . (formatter -> a -> unit) -> formatter -> a type_operator -> unit =
+  and type_operator :
+         (formatter -> type_expression -> unit)
+      -> formatter
+      -> type_operator
+      -> unit =
    fun f ppf to_ ->
-  let s = match to_ with
-    | TC_option (tv) -> Format.asprintf "option(%a)" f tv
-    | TC_list   (tv) -> Format.asprintf "list(%a)" f tv
-    | TC_set    (tv) -> Format.asprintf "set(%a)" f tv
+    let s =
+      match to_ with
+      | TC_option te -> Format.asprintf "option(%a)" f te
+      | TC_list te -> Format.asprintf "list(%a)" f te
+      | TC_set te -> Format.asprintf "set(%a)" f te
       | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
       | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
-    | TC_contract (c) -> Format.asprintf "Contract (%a)" f c
-    | TC_arrow (a , b) -> Format.asprintf "TC_Arrow (%a,%a)" f a f b
-    | TC_tuple lst -> Format.asprintf "tuple[%a]" (list_sep_d f) lst
+      | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
+      | TC_contract te  -> Format.asprintf "Contract (%a)" f te
     in
     fprintf ppf "(TO_%s)" s
-
-let literal ppf (l:literal) = match l with
-  | Literal_unit -> fprintf ppf "Unit"
-  | Literal_bool b -> fprintf ppf "%b" b
-  | Literal_int n -> fprintf ppf "%d" n
-  | Literal_nat n -> fprintf ppf "+%d" n
-  | Literal_timestamp n -> fprintf ppf "+%d" n
-  | Literal_mutez n -> fprintf ppf "%dmutez" n
-  | Literal_string s -> fprintf ppf "%S" s
-  | Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
-  | Literal_address s -> fprintf ppf "address %S" s
-  | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
-  | Literal_key s      -> fprintf ppf "key %s" s
-  | Literal_key_hash s -> fprintf ppf "key_hash %s" s
-  | Literal_signature s -> fprintf ppf "signature %s" s
-  | Literal_chain_id s -> fprintf ppf "chain_id %s" s
-
-let%expect_test _ =
-  Format.printf "%a" literal (Literal_bytes (Bytes.of_string "foo")) ;
-  [%expect{| 0x666f6f |}]
+end

src/stages/common/PP.mli

@@ -1,16 +0,0 @@
-open Types
-open Format
-
-val name             : formatter -> expression_variable -> unit 
-val type_variable    : formatter -> type_variable ->  unit
-val constructor      : formatter -> constructor ->  unit
-val label            : formatter -> label -> unit
-val constant         : formatter -> constant -> unit 
-val cmap_sep         : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a CMap.t  -> unit
-val lmap_sep         : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a LMap.t  -> unit
-val lrecord_sep      : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a LMap.t  -> unit
-val type_expression' : (formatter -> 'a -> unit) -> formatter -> 'a type_expression' -> unit
-val type_operator    : (formatter -> 'a -> unit) -> formatter -> 'a type_operator -> unit
-val type_constant    : formatter -> type_constant -> unit
-val literal          : formatter -> literal -> unit
-val list_sep_d       : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit

src/stages/common/ast_common.ml

@@ -1,3 +1,3 @@
 module Types = Types
 module PP = PP
-module Misc = Misc
+module Helpers = Helpers

src/stages/common/helpers.ml

@@ -0,0 +1,40 @@
+open Types
+
+let bind_lmap (l:_ label_map) =
+  let open Trace in
+  let open LMap in
+  let aux k v prev =
+    prev >>? fun prev' ->
+    v >>? fun v' ->
+    ok @@ add k v' prev' in
+  fold aux l (ok empty)
+
+let bind_cmap (c:_ constructor_map) =
+  let open Trace in
+  let open CMap in
+  let aux k v prev =
+    prev >>? fun prev' ->
+    v >>? fun v' ->
+    ok @@ add k v' prev' in
+  fold aux c (ok empty)
+
+let bind_fold_lmap f init (lmap:_ LMap.t) =
+  let open Trace in
+  let aux k v prev =
+    prev >>? fun prev' ->
+    f prev' k v
+  in
+  LMap.fold aux lmap init
+
+let bind_map_lmap f map = bind_lmap (LMap.map f map)
+let bind_map_cmap f map = bind_cmap (CMap.map f map)
+
+let range i j =
+  let rec aux i j acc = if i >= j then acc else aux i (j-1) (j-1 :: acc) in
+  aux i j []
+
+let label_range i j =
+  List.map (fun i -> Label (string_of_int i)) @@ range i j
+
+let is_tuple_lmap m =
+  List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m))

src/stages/common/helpers.mli

@@ -0,0 +1,18 @@
+val bind_lmap :
+  ('a * 'b list, 'c) result Types.label_map ->
+  ('a Types.label_map * 'b list, 'c) result
+val bind_cmap :
+  ('a * 'b list, 'c) result Types.constructor_map ->
+  ('a Types.constructor_map * 'b list, 'c) result
+val bind_fold_lmap :
+  ('a -> Types.label -> 'b -> ('a * 'c list, 'd) result) ->
+  ('a * 'c list, 'd) result ->
+  'b Types.label_map -> ('a * 'c list, 'd) result
+val bind_map_lmap :
+  ('a -> ('b * 'c list, 'd) result) ->
+  'a Types.label_map -> ('b Types.label_map * 'c list, 'd) result
+val bind_map_cmap :
+  ('a -> ('b * 'c list, 'd) result) ->
+  'a Types.constructor_map ->
+  ('b Types.constructor_map * 'c list, 'd) result
+val is_tuple_lmap : 'a Types.label_map -> bool

src/stages/common/misc.ml

@@ -1,94 +0,0 @@
-open Types
-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_arrow (x , y) -> TC_arrow (f x , f y)
-  | TC_tuple lst -> TC_tuple (List.map f lst)
-
-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_arrow (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
-  | TC_tuple lst -> let%bind lst = bind_map_list f lst in ok @@ TC_tuple lst
-
-let type_operator_name = function
-      TC_contract _ -> "TC_contract"
-    | TC_option   _ -> "TC_option"
-    | TC_list     _ -> "TC_list"
-    | TC_set      _ -> "TC_set"
-    | TC_map      _ -> "TC_map"
-    | TC_big_map  _ -> "TC_big_map"
-    | TC_arrow    _ -> "TC_arrow"
-    | TC_tuple    _ -> "TC_tuple"
-
-let type_expression'_of_string = function
-  | "TC_contract" , [x]     -> ok @@ T_operator(TC_contract x)
-  | "TC_option"   , [x]     -> ok @@ T_operator(TC_option x)
-  | "TC_list"     , [x]     -> ok @@ T_operator(TC_list x)
-  | "TC_set"      , [x]     -> ok @@ T_operator(TC_set x)
-  | "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_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
-     failwith "internal error: wrong number of arguments for type operator"
-
-  | "TC_unit"      , [] -> ok @@ T_constant(TC_unit)
-  | "TC_string"    , [] -> ok @@ T_constant(TC_string)
-  | "TC_bytes"     , [] -> ok @@ T_constant(TC_bytes)
-  | "TC_nat"       , [] -> ok @@ T_constant(TC_nat)
-  | "TC_int"       , [] -> ok @@ T_constant(TC_int)
-  | "TC_mutez"     , [] -> ok @@ T_constant(TC_mutez)
-  | "TC_bool"      , [] -> ok @@ T_constant(TC_bool)
-  | "TC_operation" , [] -> ok @@ T_constant(TC_operation)
-  | "TC_address"   , [] -> ok @@ T_constant(TC_address)
-  | "TC_key"       , [] -> ok @@ T_constant(TC_key)
-  | "TC_key_hash"  , [] -> ok @@ T_constant(TC_key_hash)
-  | "TC_chain_id"  , [] -> ok @@ T_constant(TC_chain_id)
-  | "TC_signature" , [] -> ok @@ T_constant(TC_signature)
-  | "TC_timestamp" , [] -> ok @@ T_constant(TC_timestamp)
-  | _,               [] ->
-     failwith "internal error: wrong number of arguments for type constant"
-  | op,              _  ->
-     failwith (Format.asprintf "internal error: unknown type operator in src/stages/common/misc.ml %s" op)
-
-let string_of_type_operator = function
-  | TC_contract  x       -> "TC_contract" , [x]
-  | TC_option    x       -> "TC_option"   , [x]
-  | TC_list      x       -> "TC_list"     , [x]
-  | TC_set       x       -> "TC_set"      , [x]
-  | TC_map       (x , y) -> "TC_map"      , [x ; y]
-  | TC_big_map   (x , y) -> "TC_big_map"  , [x ; y]
-  | TC_arrow     (x , y) -> "TC_arrow"    , [x ; y]
-  | TC_tuple     lst     -> "TC_tuple"    , lst
-
-let string_of_type_constant = function
-  | TC_unit      -> "TC_unit", []
-  | TC_string    -> "TC_string", []
-  | TC_bytes     -> "TC_bytes", []
-  | TC_nat       -> "TC_nat", []
-  | TC_int       -> "TC_int", []
-  | TC_mutez     -> "TC_mutez", []
-  | TC_bool      -> "TC_bool", []
-  | TC_operation -> "TC_operation", []
-  | TC_address   -> "TC_address", []
-  | TC_key       -> "TC_key", []
-  | TC_key_hash  -> "TC_key_hash", []
-  | TC_chain_id  -> "TC_chain_id", []
-  | TC_signature -> "TC_signature", []
-  | TC_timestamp -> "TC_timestamp", []
-
-let string_of_type_expression' = function
-  | T_operator o -> string_of_type_operator o
-  | T_constant c -> string_of_type_constant c
-  | T_sum _|T_record _|T_arrow (_, _)|T_variable _ ->
-     failwith "not a type operator or constant"
-

src/stages/common/misc.mli

@@ -1,9 +0,0 @@
-open Types
-
-val map_type_operator : ('a -> 'b) -> 'a type_operator -> 'b type_operator
-val bind_map_type_operator : ('a -> ('b * 'c list, 'd) Pervasives.result) -> 'a type_operator -> ('b type_operator * 'c list, 'd) Pervasives.result
-val type_operator_name : 'a type_operator -> string
-val type_expression'_of_string : string * 'a list -> ('a type_expression' * 'b list, 'c) Pervasives.result
-val string_of_type_operator : 'a type_operator -> string * 'a list
-val string_of_type_constant : type_constant -> string * 'a list
-val string_of_type_expression' : 'a type_expression' -> string * 'a list

src/stages/common/types.ml

@@ -1,78 +1,19 @@
-
 type expression_
+and expression_variable = expression_ Var.t
 type type_
+and type_variable = type_ Var.t
 
-type expression_variable = expression_ Var.t
-type type_variable = type_ Var.t
-type constructor = Constructor of string
+
+type constructor' = Constructor of string
 type label = Label of string
-module CMap = Map.Make( struct type t = constructor let compare (Constructor a) (Constructor b) = compare a b end)
+
+module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end)
 module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
 
 type 'a label_map = 'a LMap.t
 type 'a constructor_map = 'a CMap.t
 
-
-let bind_lmap (l:_ label_map) =
-  let open Trace in
-  let open LMap in
-  let aux k v prev =
-    prev >>? fun prev' ->
-    v >>? fun v' ->
-    ok @@ add k v' prev' in
-  fold aux l (ok empty)
-
-let bind_cmap (c:_ constructor_map) =
-  let open Trace in
-  let open CMap in
-  let aux k v prev =
-    prev >>? fun prev' ->
-    v >>? fun v' ->
-    ok @@ add k v' prev' in
-  fold aux c (ok empty)
-
-let bind_fold_lmap f init (lmap:_ LMap.t) =
-  let open Trace in
-  let aux k v prev =
-    prev >>? fun prev' ->
-    f prev' k v
-  in
-  LMap.fold aux lmap init
-
-let bind_map_lmap f map = bind_lmap (LMap.map f map)
-let bind_map_cmap f map = bind_cmap (CMap.map f map)
-
-type access =
-  | Access_tuple of int
-  | Access_record of string
-
-and access_path = access list
-
-and literal =
-  | Literal_unit
-  | Literal_bool of bool
-  | Literal_int of int
-  | Literal_nat of int
-  | Literal_timestamp of int
-  | Literal_mutez of int
-  | Literal_string of string
-  | Literal_bytes of bytes
-  | Literal_address of string
-  | Literal_signature of string
-  | Literal_key of string
-  | Literal_key_hash of string
-  | Literal_chain_id of string
-  | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
-
-(* The ast is a tree of node, 'a is the type of the node (type_variable or {type_variable, previous_type}) *)
-type 'a type_expression' = 
-  | T_sum of 'a constructor_map
-  | T_record of 'a label_map
-  | T_arrow of 'a * 'a
-  | T_variable of type_variable
-  | T_constant of type_constant
-  | T_operator of 'a type_operator
-and type_constant = 
+  and type_constant =
     | TC_unit
     | TC_string
     | TC_bytes
@@ -87,35 +28,145 @@ and type_constant =
     | TC_chain_id
     | TC_signature
     | TC_timestamp
+    | TC_void
+module type AST_PARAMETER_TYPE = sig
+  type type_meta
+end
 
-and 'a type_operator = 
-  | TC_contract of 'a
-  | TC_option of 'a
-  | TC_list of 'a
-  | TC_set of 'a
-  | TC_map of 'a * 'a
-  | TC_big_map of 'a * 'a
-  | TC_arrow of 'a * 'a
-  | TC_tuple of 'a list
+module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
+  open PARAMETER
 
-type type_base =
-  | Base_unit 
-  | Base_string 
-  | Base_bytes 
-  | Base_nat 
-  | Base_int 
-  | Base_mutez
-  | Base_bool
-  | Base_operation 
-  | Base_address
-  | Base_void
-  | Base_timestamp
-  | Base_signature
-  | Base_key
-  | Base_key_hash
-  | Base_chain_id
+  type type_content =
+    | T_sum of type_expression constructor_map
+    | T_record of type_expression label_map
+    | T_arrow of arrow
+    | T_variable of type_variable
+    | T_constant of type_constant
+    | T_operator of type_operator
 
-and ('a,'tv) matching =
+  and arrow = {type1: type_expression; type2: type_expression}
+
+  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_arrow of type_expression * type_expression
+
+
+  and type_expression = {type_content: type_content; 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_arrow (x, y) -> TC_arrow (f x, f y)
+
+  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_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
+
+  let type_operator_name = function
+        TC_contract _ -> "TC_contract"
+      | TC_option   _ -> "TC_option"
+      | TC_list     _ -> "TC_list"
+      | TC_set      _ -> "TC_set"
+      | TC_map      _ -> "TC_map"
+      | TC_big_map  _ -> "TC_big_map"
+      | TC_arrow    _ -> "TC_arrow"
+
+  let type_expression'_of_string = function
+    | "TC_contract" , [x]     -> ok @@ T_operator(TC_contract x)
+    | "TC_option"   , [x]     -> ok @@ T_operator(TC_option x)
+    | "TC_list"     , [x]     -> ok @@ T_operator(TC_list x)
+    | "TC_set"      , [x]     -> ok @@ T_operator(TC_set x)
+    | "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_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
+      failwith "internal error: wrong number of arguments for type operator"
+
+    | "TC_unit"      , [] -> ok @@ T_constant(TC_unit)
+    | "TC_string"    , [] -> ok @@ T_constant(TC_string)
+    | "TC_bytes"     , [] -> ok @@ T_constant(TC_bytes)
+    | "TC_nat"       , [] -> ok @@ T_constant(TC_nat)
+    | "TC_int"       , [] -> ok @@ T_constant(TC_int)
+    | "TC_mutez"     , [] -> ok @@ T_constant(TC_mutez)
+    | "TC_bool"      , [] -> ok @@ T_constant(TC_bool)
+    | "TC_operation" , [] -> ok @@ T_constant(TC_operation)
+    | "TC_address"   , [] -> ok @@ T_constant(TC_address)
+    | "TC_key"       , [] -> ok @@ T_constant(TC_key)
+    | "TC_key_hash"  , [] -> ok @@ T_constant(TC_key_hash)
+    | "TC_chain_id"  , [] -> ok @@ T_constant(TC_chain_id)
+    | "TC_signature" , [] -> ok @@ T_constant(TC_signature)
+    | "TC_timestamp" , [] -> ok @@ T_constant(TC_timestamp)
+    | _,               [] ->
+      failwith "internal error: wrong number of arguments for type constant"
+    | _                       ->
+      failwith "internal error: unknown type operator"
+
+  let string_of_type_operator = function
+    | TC_contract  x       -> "TC_contract" , [x]
+    | TC_option    x       -> "TC_option"   , [x]
+    | TC_list      x       -> "TC_list"     , [x]
+    | TC_set       x       -> "TC_set"      , [x]
+    | TC_map       (x , y) -> "TC_map"      , [x ; y]
+    | TC_big_map   (x , y) -> "TC_big_map"  , [x ; y]
+    | TC_arrow     (x , y) -> "TC_arrow"    , [x ; y]
+
+  let string_of_type_constant = function
+    | TC_unit      -> "TC_unit", []
+    | TC_string    -> "TC_string", []
+    | TC_bytes     -> "TC_bytes", []
+    | TC_nat       -> "TC_nat", []
+    | TC_int       -> "TC_int", []
+    | TC_mutez     -> "TC_mutez", []
+    | TC_bool      -> "TC_bool", []
+    | TC_operation -> "TC_operation", []
+    | TC_address   -> "TC_address", []
+    | TC_key       -> "TC_key", []
+    | TC_key_hash  -> "TC_key_hash", []
+    | TC_chain_id  -> "TC_chain_id", []
+    | TC_signature -> "TC_signature", []
+    | TC_timestamp -> "TC_timestamp", []
+    | TC_void      -> "TC_void", []
+
+  let string_of_type_expression' = function
+    | T_operator o -> string_of_type_operator o
+    | T_constant c -> string_of_type_constant c
+    | T_sum _ | T_record _ | T_arrow _ | T_variable _ ->
+      failwith "not a type operator or constant"
+
+end
+
+type literal =
+  | Literal_unit
+  | Literal_bool of bool
+  | Literal_int of int
+  | Literal_nat of int
+  | Literal_timestamp of int
+  | Literal_mutez of int
+  | Literal_string of string
+  | Literal_bytes of bytes
+  | Literal_address of string
+  | Literal_signature of string
+  | Literal_key of string
+  | Literal_key_hash of string
+  | Literal_chain_id of string
+  | Literal_void
+  | Literal_operation of
+      Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
+and ('a,'tv) matching_content =
   | Match_bool of {
       match_true : 'a ;
       match_false : 'a ;
@@ -129,9 +180,9 @@ and ('a,'tv) matching =
       match_some : expression_variable * 'a * 'tv;
     }
   | Match_tuple of (expression_variable list * 'a) * 'tv list
-  | Match_variant of ((constructor * expression_variable) * 'a) list * 'tv
+  | Match_variant of ((constructor' * expression_variable) * 'a) list * 'tv
 
-type constant = 
+and constant' =
   | C_INT
   | C_UNIT
   | C_NIL
@@ -201,6 +252,8 @@ type constant =
   | C_MAP
   | C_MAP_EMPTY
   | C_MAP_LITERAL
+  | C_MAP_GET
+  | C_MAP_GET_FORCE
   | C_MAP_ADD
   | C_MAP_REMOVE
   | C_MAP_UPDATE
@@ -218,6 +271,7 @@ type constant =
   | C_SHA256
   | C_SHA512
   | C_BLAKE2b
+  | C_HASH
   | C_HASH_KEY
   | C_CHECK_SIGNATURE
   | C_CHAIN_ID

src/stages/mini_c/PP.ml

@@ -2,7 +2,6 @@
 open Simple_utils.PP_helpers
 open Types
 open Format
-include Stage_common.PP
 
 let list_sep_d x = list_sep x (const " , ")
 
@@ -10,27 +9,10 @@ let space_sep ppf () = fprintf ppf " "
 
 let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R"
 
-let type_base ppf : type_base -> _ = function
-  | Base_unit -> fprintf ppf "unit"
-  | Base_void -> fprintf ppf "void"
-  | Base_bool -> fprintf ppf "bool"
-  | Base_int -> fprintf ppf "int"
-  | Base_nat -> fprintf ppf "nat"
-  | Base_mutez -> fprintf ppf "tez"
-  | Base_string -> fprintf ppf "string"
-  | Base_address -> fprintf ppf "address"
-  | Base_timestamp -> fprintf ppf "timestamp"
-  | Base_bytes -> fprintf ppf "bytes"
-  | Base_operation -> fprintf ppf "operation"
-  | Base_signature -> fprintf ppf "signature"
-  | Base_key -> fprintf ppf "key"
-  | Base_key_hash -> fprintf ppf "key_hash"
-  | Base_chain_id -> fprintf ppf "chain_id"
-
 let rec type_variable ppf : type_value -> _ = function
   | T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b
   | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b
-  | T_base b -> type_base ppf b
+  | T_base b -> type_constant ppf b
   | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b
   | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v
   | T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v
@@ -44,11 +26,31 @@ and annotated ppf : type_value annotated -> _ = function
   | (None, a) -> type_variable ppf a
 
 and environment_element ppf ((n, tv) : environment_element) =
-  Format.fprintf ppf "%a : %a" Stage_common.PP.name n type_variable tv
+  Format.fprintf ppf "%a : %a" Var.pp n type_variable tv
 
 and environment ppf (x:environment) =
   fprintf ppf "Env[%a]" (list_sep_d environment_element) x
 
+and type_constant ppf (tc:type_constant) : unit =
+  let s = match tc with 
+    | TC_unit      -> "unit"
+    | TC_string    -> "string"
+    | TC_bytes     -> "bytes"
+    | TC_nat       -> "nat"
+    | TC_int       -> "int"
+    | TC_mutez     -> "mutez"
+    | TC_bool      -> "bool"
+    | TC_operation -> "operation"
+    | TC_address   -> "address"
+    | TC_key       -> "key"
+    | TC_key_hash  -> "key_hash"
+    | TC_signature -> "signatuer"
+    | TC_timestamp -> "timestamp"
+    | TC_chain_id  -> "chain_id"
+    | TC_void      -> "void"
+    in
+  fprintf ppf "(TC %s)" s
+
 let rec value ppf : value -> unit = function
   | D_bool b -> fprintf ppf "%b" b
   | D_operation _ -> fprintf ppf "operation[...bytes]"
@@ -73,12 +75,16 @@ let rec value ppf : value -> unit = function
 and value_assoc ppf : (value * value) -> unit = fun (a, b) ->
   fprintf ppf "%a -> %a" value a value b
 
+and expression ppf (e:expression) =
+  fprintf ppf "%a" expression' e.content
+
 and expression' ppf (e:expression') = match e with
   | E_skip -> fprintf ppf "skip"
   | E_closure x -> fprintf ppf "C(%a)" function_ x
-  | E_variable v -> fprintf ppf "V(%a)" Stage_common.PP.name v
+  | E_variable v -> fprintf ppf "V(%a)" Var.pp v
   | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
-  | E_constant(p, lst) -> fprintf ppf "%a %a" Stage_common.PP.constant p (pp_print_list ~pp_sep:space_sep expression) lst
+
+  | E_constant c -> fprintf ppf "%a %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments
   | E_literal v -> fprintf ppf "L(%a)" value v
   | E_make_empty_map _ -> fprintf ppf "map[]"
   | E_make_empty_big_map _ -> fprintf ppf "big_map[]"
@@ -86,26 +92,24 @@ and expression' ppf (e:expression') = match e with
   | E_make_empty_set _ -> fprintf ppf "set[]"
   | E_make_none _ -> fprintf ppf "none"
   | E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
-  | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Stage_common.PP.name name expression s
-  | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Stage_common.PP.name hd_name Stage_common.PP.name tl_name expression cons
+  | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s
+  | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Var.pp hd_name Var.pp tl_name expression cons
   | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
-      fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Stage_common.PP.name name_l expression l Stage_common.PP.name name_r expression r
+      fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Var.pp name_l expression l Var.pp name_r expression r
   | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b
   | E_let_in ((name , _) , inline, expr , body) ->
-      fprintf ppf "let %a = %a%a in ( %a )" Stage_common.PP.name name expression expr option_inline inline expression body
+      fprintf ppf "let %a = %a%a in ( %a )" Var.pp name expression expr option_inline inline expression body
   | E_iterator (b , ((name , _) , body) , expr) ->
-      fprintf ppf "for_%a %a of %a do ( %a )" Stage_common.PP.constant b Stage_common.PP.name name expression expr expression body
+      fprintf ppf "for_%a %a of %a do ( %a )" constant b Var.pp name expression expr expression body
   | E_fold (((name , _) , body) , collection , initial) ->
-      fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Stage_common.PP.name name expression body
-  | E_assignment (r , path , e) ->
-      fprintf ppf "%a.%a := %a" Stage_common.PP.name r (list_sep lr (const ".")) path expression e
-  | E_update (r, (path,e)) ->
-      fprintf ppf "%a with {%a=%a}" expression r (list_sep lr (const ".")) path expression e
-  | E_while (e , b) ->
-      fprintf ppf "while (%a) %a" expression e expression b
+      fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body
 
-and expression : _ -> expression -> _ = fun ppf e ->
-  expression' ppf e.content
+  | E_assignment (r , path , e) ->
+      fprintf ppf "%a.%a := %a" Var.pp r (list_sep lr (const ".")) path expression e
+  | E_record_update (r, path,update) ->
+      fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update
+  | E_while (e , b) ->
+      fprintf ppf "while %a do %a" expression e expression b
 
 and expression_with_type : _ -> expression -> _  = fun ppf e ->
   fprintf ppf "%a : %a"
@@ -114,11 +118,10 @@ and expression_with_type : _ -> expression -> _  = fun ppf e ->
 
 and function_ ppf ({binder ; body}:anon_function) =
   fprintf ppf "fun %a -> (%a)"
-    Stage_common.PP.name binder
+    Var.pp binder
     expression body
 
-and assignment ppf ((n, i, e):assignment) = 
-  fprintf ppf "%a = %a%a;" Stage_common.PP.name n expression e option_inline i
+and assignment ppf ((n, i, e):assignment) = fprintf ppf "%a = %a%a;" Var.pp n expression e option_inline i
 
 and option_inline ppf inline = 
   if inline then 
@@ -126,21 +129,129 @@ and option_inline ppf inline =
   else
     fprintf ppf ""
 
-and declaration ppf ((n, i, e):assignment) = 
-  fprintf ppf "let %a = %a%a;" Stage_common.PP.name n expression e option_inline i
+and declaration ppf ((n,i, e):assignment) = fprintf ppf "let %a = %a%a;" Var.pp n expression e option_inline i
 
-let tl_statement ppf (ass, _) = assignment ppf ass
+and tl_statement ppf (ass, _) = assignment ppf ass
 
-let program ppf (p:program) =
+and program ppf (p:program) =
   fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p
 
+and constant ppf : constant' -> unit = function
+  | C_INT                   -> fprintf ppf "INT"
+  | C_UNIT                  -> fprintf ppf "UNIT"
+  | C_NIL                   -> fprintf ppf "NIL"
+  | C_NOW                   -> fprintf ppf "NOW"
+  | C_IS_NAT                -> fprintf ppf "IS_NAT"
+  | C_SOME                  -> fprintf ppf "SOME"
+  | C_NONE                  -> fprintf ppf "NONE"
+  | C_ASSERTION             -> fprintf ppf "ASSERTION"
+  | C_ASSERT_INFERRED       -> fprintf ppf "ASSERT_INFERRED"
+  | C_FAILWITH              -> fprintf ppf "FAILWITH"
+  | C_UPDATE                -> fprintf ppf "UPDATE"
+  (* Loops *)
+  | C_FOLD                  -> fprintf ppf "FOLD"
+  | C_FOLD_WHILE            -> fprintf ppf "FOLD_WHILE"
+  | C_CONTINUE              -> fprintf ppf "CONTINUE"
+  | C_STOP                  -> fprintf ppf "STOP"
+  | C_ITER                  -> fprintf ppf "ITER"
+  (* MATH *)
+  | C_NEG                   -> fprintf ppf "NEG"
+  | C_ABS                   -> fprintf ppf "ABS"
+  | C_ADD                   -> fprintf ppf "ADD"
+  | C_SUB                   -> fprintf ppf "SUB"
+  | C_MUL                   -> fprintf ppf "MUL"
+  | C_DIV                   -> fprintf ppf "DIV"
+  | C_MOD                   -> fprintf ppf "MOD"
+  (* LOGIC *)
+  | C_NOT                   -> fprintf ppf "NOT"
+  | C_AND                   -> fprintf ppf "AND"
+  | C_OR                    -> fprintf ppf "OR"
+  | C_XOR                   -> fprintf ppf "XOR"
+  (* COMPARATOR *)
+  | C_EQ                    -> fprintf ppf "EQ"
+  | C_NEQ                   -> fprintf ppf "NEQ"
+  | C_LT                    -> fprintf ppf "LT"
+  | C_GT                    -> fprintf ppf "GT"
+  | C_LE                    -> fprintf ppf "LE"
+  | C_GE                    -> fprintf ppf "GE"
+  (* Bytes/ String *)
+  | C_SIZE                  -> fprintf ppf "SIZE"
+  | C_CONCAT                -> fprintf ppf "CONCAT"
+  | C_SLICE                 -> fprintf ppf "SLICE"
+  | C_BYTES_PACK            -> fprintf ppf "BYTES_PACK"
+  | C_BYTES_UNPACK          -> fprintf ppf "BYTES_UNPACK"
+  | C_CONS                  -> fprintf ppf "CONS"
+  (* Pair *)
+  | C_PAIR                  -> fprintf ppf "PAIR"
+  | C_CAR                   -> fprintf ppf "CAR"
+  | C_CDR                   -> fprintf ppf "CDR"
+  | C_LEFT                  -> fprintf ppf "LEFT"
+  | C_RIGHT                 -> fprintf ppf "RIGHT"
+  | C_LSL                   -> fprintf ppf "LSL"
+  | C_LSR                   -> fprintf ppf "LSR"
+  (* Set *)
+  | C_SET_EMPTY             -> fprintf ppf "SET_EMPTY"
+  | C_SET_LITERAL           -> fprintf ppf "SET_LITERAL"
+  | C_SET_ADD               -> fprintf ppf "SET_ADD"
+  | C_SET_REMOVE            -> fprintf ppf "SET_REMOVE"
+  | C_SET_ITER              -> fprintf ppf "SET_ITER"
+  | C_SET_FOLD              -> fprintf ppf "SET_FOLD"
+  | C_SET_MEM               -> fprintf ppf "SET_MEM"
+  (* List *)
+  | C_LIST_ITER             -> fprintf ppf "LIST_ITER"
+  | C_LIST_MAP              -> fprintf ppf "LIST_MAP"
+  | C_LIST_FOLD             -> fprintf ppf "LIST_FOLD"
+  | C_LIST_CONS             -> fprintf ppf "LIST_CONS"
+  (* Maps *)
+  | C_MAP                   -> fprintf ppf "MAP"
+  | C_MAP_EMPTY             -> fprintf ppf "MAP_EMPTY"
+  | C_MAP_LITERAL           -> fprintf ppf "MAP_LITERAL"
+  | C_MAP_GET               -> fprintf ppf "MAP_GET"
+  | C_MAP_GET_FORCE         -> fprintf ppf "MAP_GET_FORCE"
+  | C_MAP_ADD               -> fprintf ppf "MAP_ADD"
+  | C_MAP_REMOVE            -> fprintf ppf "MAP_REMOVE"
+  | C_MAP_UPDATE            -> fprintf ppf "MAP_UPDATE"
+  | C_MAP_ITER              -> fprintf ppf "MAP_ITER"
+  | C_MAP_MAP               -> fprintf ppf "MAP_MAP"
+  | C_MAP_FOLD              -> fprintf ppf "MAP_FOLD"
+  | C_MAP_MEM               -> fprintf ppf "MAP_MEM"
+  | C_MAP_FIND              -> fprintf ppf "MAP_FIND"
+  | C_MAP_FIND_OPT          -> fprintf ppf "MAP_FIND_OP"
+  (* Big Maps *)
+  | C_BIG_MAP               -> fprintf ppf "BIG_MAP"
+  | C_BIG_MAP_EMPTY         -> fprintf ppf "BIG_MAP_EMPTY"
+  | C_BIG_MAP_LITERAL       -> fprintf ppf "BIG_MAP_LITERAL"
+  (* Crypto *)
+  | C_SHA256                -> fprintf ppf "SHA256"
+  | C_SHA512                -> fprintf ppf "SHA512"
+  | C_BLAKE2b               -> fprintf ppf "BLAKE2b"
+  | C_HASH                  -> fprintf ppf "HASH"
+  | C_HASH_KEY              -> fprintf ppf "HASH_KEY"
+  | C_CHECK_SIGNATURE       -> fprintf ppf "CHECK_SIGNATURE"
+  | C_CHAIN_ID              -> fprintf ppf "CHAIN_ID"
+  (* Blockchain *)
+  | C_CALL                  -> fprintf ppf "CALL"
+  | C_CONTRACT              -> fprintf ppf "CONTRACT"
+  | C_CONTRACT_ENTRYPOINT   -> fprintf ppf "CONTRACT_ENTRYPOINT"
+  | C_CONTRACT_OPT          -> fprintf ppf "CONTRACT OPT"
+  | C_CONTRACT_ENTRYPOINT_OPT -> fprintf ppf "CONTRACT_ENTRYPOINT OPT"
+  | C_AMOUNT                -> fprintf ppf "AMOUNT"
+  | C_BALANCE               -> fprintf ppf "BALANCE"
+  | C_SOURCE                -> fprintf ppf "SOURCE"
+  | C_SENDER                -> fprintf ppf "SENDER"
+  | C_ADDRESS               -> fprintf ppf "ADDRESS"
+  | C_SELF_ADDRESS          -> fprintf ppf "SELF_ADDRESS"
+  | C_IMPLICIT_ACCOUNT      -> fprintf ppf "IMPLICIT_ACCOUNT"
+  | C_STEPS_TO_QUOTA        -> fprintf ppf "STEPS_TO_QUOTA"
+  | C_SET_DELEGATE          -> fprintf ppf "SET_DELEGATE"
+
 let%expect_test _ =
   Format.printf "%a" value (D_bytes (Bytes.of_string "foo")) ;
   [%expect{| 0x666f6f |}]
 
 let%expect_test _ =
   let pp = expression' Format.std_formatter in
-  let dummy_type = T_base Base_unit in
+  let dummy_type = T_base TC_unit in
   let wrap e = { content = e ; type_value = dummy_type } in
   pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ;
   [%expect{|

src/stages/mini_c/PP.mli

@@ -30,3 +30,5 @@ val declaration : formatter -> assignment -> unit
 val tl_statement : formatter -> assignment * 'a -> unit
 *)
 val program : formatter -> program -> unit
+
+val constant : formatter -> constant' -> unit

src/stages/mini_c/combinators.ml

@@ -18,7 +18,7 @@ module Expression = struct
     type_value = t ;
   }
 
-  let pair : t -> t -> t' = fun a b -> E_constant (C_PAIR , [ a ; b ])
+  let pair : t -> t -> t' = fun a b -> E_constant { cons_name = C_PAIR; arguments = [ a ; b ]}
 
 end
 
@@ -152,7 +152,7 @@ let get_t_contract t = match t with
   | _ -> fail @@ wrong_type "contract" t
 
 let get_t_operation t = match t with
-  | T_base Base_operation -> ok ()
+  | T_base TC_operation -> ok ()
   | _ -> fail @@ wrong_type "operation" t
 
 let get_operation (v:value) = match v with
@@ -160,9 +160,9 @@ let get_operation (v:value) = match v with
   | _ -> simple_fail "not an operation"
 
 
-let t_int : type_value = T_base Base_int
-let t_unit : type_value = T_base Base_unit
-let t_nat : type_value = T_base Base_nat
+let t_int : type_value = T_base TC_int
+let t_unit : type_value = T_base TC_unit
+let t_nat : type_value = T_base TC_nat
 
 let t_function x y : type_value = T_function ( x , y )
 let t_pair x y : type_value = T_pair ( x , y )

src/stages/mini_c/misc.ml

@@ -41,7 +41,7 @@ module Free_variables = struct
     | E_literal v -> value b v
     | E_closure f -> lambda b f
     | E_skip -> empty
-    | E_constant (_, xs) -> unions @@ List.map self xs
+    | E_constant (c) -> unions @@ List.map self c.arguments
     | E_application (f, x) -> unions @@ [ self f ; self x ]
     | E_variable n -> var_name b n
     | E_make_empty_map _ -> empty
@@ -81,7 +81,7 @@ module Free_variables = struct
     | E_sequence (x, y) -> union (self x) (self y)
     (* NB different from ast_typed... *)
     | E_assignment (v, _, e) -> unions [ var_name b v ; self e ]
-    | E_update (r, (_,e)) -> union (self r) (self e)
+    | E_record_update (r, _,e) -> union (self r) (self e)
     | E_while (cond , body) -> union (self cond) (self body)
 
   and var_name : bindings -> var_name -> bindings = fun b n ->

src/stages/mini_c/types.ml

@@ -1,5 +1,5 @@
-include Stage_common.Types
 
+include Stage_common.Types
 
 type 'a annotated = string option * 'a
 
@@ -7,7 +7,7 @@ type type_value =
   | T_pair of (type_value annotated * type_value annotated)
   | T_or of (type_value annotated * type_value annotated)
   | T_function of (type_value * type_value)
-  | T_base of type_base
+  | T_base of type_constant
   | T_map of (type_value * type_value)
   | T_big_map of (type_value * type_value)
   | T_list of type_value
@@ -19,13 +19,13 @@ and environment_element = expression_variable * type_value
 
 and environment = environment_element list
 
-type environment_wrap = {
+and environment_wrap = {
   pre_environment : environment ;
   post_environment : environment ;
 }
 
-type var_name = expression_variable
-type fun_name = expression_variable
+and var_name = expression_variable
+and fun_name = expression_variable
 
 type inline = bool
 
@@ -56,7 +56,7 @@ and expression' =
   | E_literal of value
   | E_closure of anon_function
   | E_skip
-  | E_constant of constant * expression list
+  | E_constant of constant
   | E_application of (expression * expression)
   | E_variable of var_name
   | E_make_empty_map of (type_value * type_value)
@@ -64,7 +64,7 @@ and expression' =
   | E_make_empty_list of type_value
   | E_make_empty_set of type_value
   | E_make_none of type_value
-  | E_iterator of (constant * ((var_name * type_value) * expression) * expression)
+  | E_iterator of constant' * ((var_name * type_value) * expression) * expression
   | E_fold of (((var_name * type_value) * expression) * expression * expression)
   | E_if_bool of (expression * expression * expression)
   | E_if_none of expression * expression * ((var_name * type_value) * expression)
@@ -73,7 +73,7 @@ and expression' =
   | E_let_in of ((var_name * type_value) * inline * expression * expression)
   | E_sequence of (expression * expression)
   | E_assignment of (expression_variable * [`Left | `Right] list * expression)
-  | E_update of (expression * ([`Left | `Right] list * expression))
+  | E_record_update of (expression * [`Left | `Right] list * expression)
   | E_while of (expression * expression)
 
 and expression = {
@@ -81,6 +81,11 @@ and expression = {
   type_value : type_value ;
 }
 
+and constant = {
+  cons_name : constant'; (* this is at the end because it is huge *)
+  arguments : expression list;
+}
+
 and assignment = var_name * inline * expression
 
 and toplevel_statement = assignment * environment_wrap

src/stages/typesystem/core.ml

@@ -1,5 +1,6 @@
-include Stage_common.Types
 
+type type_variable = Ast_typed.type_variable
+type type_expression = Ast_typed.type_expression
 
 (* generate a new type variable and gave it an id *)
 let fresh_type_variable : ?name:string -> unit -> type_variable =
@@ -10,7 +11,6 @@ let fresh_type_variable : ?name:string -> unit -> type_variable =
 type constant_tag =
   | C_arrow     (* * -> * -> * *) (* isn't this wrong*)
   | C_option    (* * -> * *)
-  | C_tuple     (* * … -> * *)
   | C_record    (* ( label , * ) … -> * *)
   | C_variant   (* ( label , * ) … -> * *)
   | C_map       (* * -> * -> * *)
@@ -33,9 +33,7 @@ type constant_tag =
   | C_contract  (* * -> * *)
   | C_chain_id  (* * *)
 
-type accessor =
-  | L_int of int
-  | L_string of string
+type accessor = Ast_typed.label
 
 (* Weird stuff; please explain *)
 type type_value =
@@ -71,33 +69,31 @@ and typeclass = type_value list list
 
 open Trace
 let type_expression'_of_simple_c_constant = function
-  | C_contract  , [x]     -> ok @@ T_operator(TC_contract x)
-  | C_option    , [x]     -> ok @@ T_operator(TC_option x)
-  | C_list      , [x]     -> ok @@ T_operator(TC_list x)
-  | C_set       , [x]     -> ok @@ T_operator(TC_set x)
-  | C_map       , [x ; y] -> ok @@ T_operator(TC_map (x , y))
-  | C_big_map   , [x ; y] -> ok @@ T_operator(TC_big_map (x, y))
-  | C_arrow     , [x ; y] -> ok @@ T_operator(TC_arrow (x, y))
-  | C_tuple     , lst     -> ok @@ T_operator(TC_tuple lst)
+  | C_contract  , [x]     -> ok @@ Ast_typed.T_operator(TC_contract x)
+  | C_option    , [x]     -> ok @@ Ast_typed.T_operator(TC_option x)
+  | C_list      , [x]     -> ok @@ Ast_typed.T_operator(TC_list x)
+  | C_set       , [x]     -> ok @@ Ast_typed.T_operator(TC_set x)
+  | C_map       , [x ; y] -> ok @@ Ast_typed.T_operator(TC_map (x , y))
+  | C_big_map   , [x ; y] -> ok @@ Ast_typed.T_operator(TC_big_map (x, y))
+  | C_arrow     , [x ; y] -> ok @@ Ast_typed.T_operator(TC_arrow (x, y))
   | C_record    , _lst    -> ok @@ failwith "records are not supported yet: T_record lst"
   | C_variant   , _lst    -> ok @@ failwith "sums are not supported yet: T_sum lst"
   | (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow ), _ ->
      failwith "internal error: wrong number of arguments for type operator"
 
-  | C_unit      , [] -> ok @@ T_constant(TC_unit)
-  | C_string    , [] -> ok @@ T_constant(TC_string)
-  | C_bytes     , [] -> ok @@ T_constant(TC_bytes)
-  | C_nat       , [] -> ok @@ T_constant(TC_nat)
-  | C_int       , [] -> ok @@ T_constant(TC_int)
-  | C_mutez     , [] -> ok @@ T_constant(TC_mutez)
-  | C_bool      , [] -> ok @@ T_constant(TC_bool)
-  | C_operation , [] -> ok @@ T_constant(TC_operation)
-  | C_address   , [] -> ok @@ T_constant(TC_address)
-  | C_key       , [] -> ok @@ T_constant(TC_key)
-  | C_key_hash  , [] -> ok @@ T_constant(TC_key_hash)
-  | C_chain_id  , [] -> ok @@ T_constant(TC_chain_id)
-  | C_signature , [] -> ok @@ T_constant(TC_signature)
-  | C_timestamp , [] -> ok @@ T_constant(TC_timestamp)
+  | C_unit      , [] -> ok @@ Ast_typed.T_constant(TC_unit)
+  | C_string    , [] -> ok @@ Ast_typed.T_constant(TC_string)
+  | C_bytes     , [] -> ok @@ Ast_typed.T_constant(TC_bytes)
+  | C_nat       , [] -> ok @@ Ast_typed.T_constant(TC_nat)
+  | C_int       , [] -> ok @@ Ast_typed.T_constant(TC_int)
+  | C_mutez     , [] -> ok @@ Ast_typed.T_constant(TC_mutez)
+  | C_bool      , [] -> ok @@ Ast_typed.T_constant(TC_bool)
+  | C_operation , [] -> ok @@ Ast_typed.T_constant(TC_operation)
+  | C_address   , [] -> ok @@ Ast_typed.T_constant(TC_address)
+  | C_key       , [] -> ok @@ Ast_typed.T_constant(TC_key)
+  | C_key_hash  , [] -> ok @@ Ast_typed.T_constant(TC_key_hash)
+  | C_chain_id  , [] -> ok @@ Ast_typed.T_constant(TC_chain_id)
+  | C_signature , [] -> ok @@ Ast_typed.T_constant(TC_signature)
+  | C_timestamp , [] -> ok @@ Ast_typed.T_constant(TC_timestamp)
   | (C_unit | C_string | C_bytes | C_nat | C_int | C_mutez | C_bool | C_operation | C_address | C_key | C_key_hash | C_chain_id | C_signature | C_timestamp), _::_ ->
      failwith "internal error: wrong number of arguments for type constant"
-

src/stages/typesystem/misc.ml

@@ -9,7 +9,7 @@ module Substitution = struct
     module T = Ast_typed
     (* module TSMap = Trace.TMap(String) *)
 
-    type substs = variable:type_variable -> T.type_value' option (* this string is a type_name or type_variable I think *)
+    type substs = variable:type_variable -> T.type_content option (* this string is a type_name or type_variable I think *)
     let mk_substs ~v ~expr = (v , expr)
 
     type 'a w = substs:substs -> 'a -> 'a result
@@ -18,20 +18,19 @@ module Substitution = struct
     and s_environment_element_definition ~substs = function
       | T.ED_binder -> ok @@ T.ED_binder
       | T.ED_declaration (val_, free_variables) ->
-        let%bind val_ = s_annotated_expression ~substs  val_ in
+        let%bind val_ = s_expression ~substs  val_ in
         let%bind free_variables = bind_map_list (s_variable ~substs) free_variables in
         ok @@ T.ED_declaration (val_, free_variables)
     and s_environment : T.environment w = fun ~substs env ->
       bind_map_list (fun (variable, T.{ type_value; source_environment; definition }) ->
-          let%bind variable = s_variable ~substs variable in
-          let%bind type_value = s_type_value ~substs type_value in
+          let%bind type_value = s_type_expression ~substs type_value in
           let%bind source_environment = s_full_environment ~substs source_environment in
           let%bind definition = s_environment_element_definition ~substs definition in
           ok @@ (variable, T.{ type_value; source_environment; definition })) env
     and s_type_environment : T.type_environment w = fun ~substs tenv ->
       bind_map_list (fun (type_variable , type_value) ->
         let%bind type_variable = s_type_variable ~substs type_variable in
-        let%bind type_value = s_type_value ~substs type_value in
+        let%bind type_value = s_type_expression ~substs type_value in
         ok @@ (type_variable , type_value)) tenv
     and s_small_environment : T.small_environment w = fun ~substs (environment, type_environment) ->
       let%bind environment = s_environment ~substs environment in
@@ -58,11 +57,11 @@ module Substitution = struct
       let () = ignore @@ substs in
       ok l
     
-    and s_build_in : T.constant w = fun ~substs b ->
+    and s_build_in : T.constant' w = fun ~substs b ->
       let () = ignore @@ substs in
       ok b
 
-    and s_constructor : T.constructor w = fun ~substs c ->
+    and s_constructor : T.constructor' w = fun ~substs c ->
       let () = ignore @@ substs in
       ok c
 
@@ -71,10 +70,7 @@ module Substitution = struct
       let () = ignore @@ substs in
       ok @@ type_name
 
-    and s_type_value' : T.type_value' w = fun ~substs -> function
-        | T.T_operator (TC_tuple type_value_list) ->
-          let%bind type_value_list = bind_map_list (s_type_value ~substs) type_value_list in
-          ok @@ T.T_operator (TC_tuple type_value_list)
+    and s_type_content : T.type_content w = fun ~substs -> function
         | T.T_sum _ -> failwith "TODO: T_sum"
         | T.T_record _ -> failwith "TODO: T_record"
         | T.T_constant type_name ->
@@ -83,43 +79,46 @@ module Substitution = struct
         | T.T_variable variable ->
            begin
              match substs ~variable with
-             | Some expr -> s_type_value' ~substs expr (* TODO: is it the right thing to recursively examine this? We mustn't go into an infinite loop. *)
+             | Some expr -> s_type_content ~substs expr (* TODO: is it the right thing to recursively examine this? We mustn't go into an infinite loop. *)
              | None -> ok @@ T.T_variable variable
            end
         | T.T_operator type_name_and_args ->
-          let%bind type_name_and_args = T.Misc.bind_map_type_operator (s_type_value ~substs) type_name_and_args in
+          let%bind type_name_and_args = T.bind_map_type_operator (s_type_expression ~substs) type_name_and_args in
           ok @@ T.T_operator type_name_and_args
         | T.T_arrow _ ->
           let _TODO = substs in
           failwith "TODO: T_function"
 
-    and s_type_expression' : _ Ast_simplified.type_expression' w = fun ~substs -> function
+    and s_simpl_type_content : Ast_simplified.type_content w = fun ~substs -> function
       | Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression sum"
       | Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record"
-      | Ast_simplified.T_arrow (_, _) -> failwith "TODO: subst: unimplemented case s_type_expression arrow"
+      | Ast_simplified.T_arrow _ -> failwith "TODO: subst: unimplemented case s_type_expression arrow"
       | Ast_simplified.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression variable"
       | Ast_simplified.T_operator op ->
          let%bind op =
-           Ast_simplified.Misc.bind_map_type_operator
-             (s_type_expression ~substs)
+           Ast_simplified.bind_map_type_operator
+             (s_simpl_type_expression ~substs)
              op in
          (* TODO: when we have generalized operators, we might need to subst the operator name itself? *)
          ok @@ Ast_simplified.T_operator op
       | Ast_simplified.T_constant constant ->
          ok @@ Ast_simplified.T_constant constant
 
-    and s_type_expression : Ast_simplified.type_expression w = fun ~substs {type_expression'} ->
-      let%bind type_expression' = s_type_expression' ~substs type_expression' in
-      ok @@ Ast_simplified.{type_expression'}
+    and s_simpl_type_expression : Ast_simplified.type_expression w = fun ~substs {type_content;type_meta} ->
+      let%bind type_content = s_simpl_type_content ~substs type_content in
+      ok @@ Ast_simplified.{type_content;type_meta}
 
-    and s_type_value : T.type_value w = fun ~substs { type_value'; simplified } ->
-      let%bind type_value' = s_type_value' ~substs type_value' in
-      let%bind simplified = bind_map_option (s_type_expression ~substs) simplified in
-      ok @@ T.{ type_value'; simplified }
+    and s_type_expression : T.type_expression w = fun ~substs { type_content; type_meta } ->
+      let%bind type_content = s_type_content ~substs type_content in
+      let%bind type_meta = bind_map_option (s_simpl_type_expression ~substs) type_meta in
+      ok @@ T.{ type_content; type_meta}
     and s_literal : T.literal w = fun ~substs -> function
       | T.Literal_unit ->
         let () = ignore @@ substs in
         ok @@ T.Literal_unit
+      | T.Literal_void ->
+        let () = ignore @@ substs in
+        ok @@ T.Literal_void
       | (T.Literal_bool _ as x)
       | (T.Literal_int _ as x)
       | (T.Literal_nat _ as x)
@@ -137,127 +136,103 @@ module Substitution = struct
     and s_matching_expr : T.matching_expr w = fun ~substs _ ->
       let _TODO = substs in
       failwith "TODO: subst: unimplemented case s_matching"
-    and s_named_type_value : T.named_type_value w = fun ~substs _ ->
-      let _TODO = substs in
-      failwith "TODO: subst: unimplemented case s_named_type_value"
-    and s_access_path  : T.access_path w = fun ~substs _ ->
+    and s_accessor  : T.accessor w = fun ~substs _ ->
       let _TODO = substs in
       failwith "TODO: subst: unimplemented case s_access_path"
 
-    and s_expression : T.expression w = fun ~(substs : substs) -> function
+    and s_expression_content : T.expression_content w = fun ~(substs : substs) -> function
       | T.E_literal         x ->
         let%bind x = s_literal ~substs x in
         ok @@ T.E_literal x
-      | T.E_constant        (var, vals) ->
-        let%bind var = s_build_in ~substs var in
-        let%bind vals = bind_map_list (s_annotated_expression ~substs) vals in
-        ok @@ T.E_constant (var, vals)
+      | T.E_constant   {cons_name;arguments} ->
+        let%bind cons_name = s_build_in ~substs cons_name in
+        let%bind arguments = bind_map_list (s_expression ~substs) arguments in
+        ok @@ T.E_constant {cons_name;arguments}
       | T.E_variable        tv ->
         let%bind tv = s_variable ~substs tv in
         ok @@ T.E_variable tv
-      | T.E_application     (val1 , val2) ->
-        let%bind val1 = s_annotated_expression ~substs val1 in
-        let%bind val2 = s_annotated_expression ~substs val2 in
-        ok @@ T.E_application (val1 , val2)
-      | T.E_lambda          { binder; body } ->
+      | T.E_application {expr1;expr2} ->
+        let%bind expr1 = s_expression ~substs expr1 in
+        let%bind expr2 = s_expression ~substs expr2 in
+        ok @@ T.E_application {expr1;expr2}
+      | T.E_lambda          { binder; result } ->
         let%bind binder = s_variable ~substs binder in
-        let%bind body = s_annotated_expression ~substs body in
-        ok @@ T.E_lambda { binder; body }
-      | T.E_let_in          { binder; rhs; result; inline } ->
-        let%bind binder = s_variable ~substs binder in
-        let%bind rhs = s_annotated_expression ~substs rhs in
-        let%bind result = s_annotated_expression ~substs result in
-        ok @@ T.E_let_in { binder; rhs; result; inline }
-      | T.E_tuple           vals ->
-        let%bind vals = bind_map_list (s_annotated_expression ~substs) vals in
-        ok @@ T.E_tuple vals
-      | T.E_tuple_accessor  (val_, i) ->
-        let%bind val_ = s_annotated_expression ~substs val_ in
-        let i = i in
-        ok @@ T.E_tuple_accessor (val_, i)
-      | T.E_constructor     (tvar, val_) ->
-        let%bind tvar = s_constructor ~substs tvar in
-        let%bind val_ = s_annotated_expression ~substs val_ in
-        ok @@ T.E_constructor (tvar, val_)
+        let%bind result = s_expression ~substs result in
+        ok @@ T.E_lambda { binder; result }
+      | T.E_let_in          { let_binder; rhs; let_result; inline } ->
+        let%bind let_binder = s_variable ~substs let_binder in
+        let%bind rhs = s_expression ~substs rhs in
+        let%bind let_result = s_expression ~substs let_result in
+        ok @@ T.E_let_in { let_binder; rhs; let_result; inline }
+      | T.E_constructor  {constructor;element} ->
+        let%bind constructor = s_constructor ~substs constructor in
+        let%bind element = s_expression ~substs element in
+        ok @@ T.E_constructor {constructor;element}
       | T.E_record          aemap ->
         let _TODO = aemap in
         failwith "TODO: subst in record"
         (* let%bind aemap = TSMap.bind_map_Map (fun ~k:key ~v:val_ ->
-         *     let key = s_type_variable ~substs key in
-         *     let val_ = s_annotated_expression ~substs val_ in
+         *     let key = s_type_variable ~v ~expr key in
+         *     let val_ = s_expression ~v ~expr val_ in
          *     ok @@ (key , val_)) aemap in
          * ok @@ T.E_record aemap *)
-      | T.E_record_accessor (val_, l) ->
-        let%bind val_ = s_annotated_expression ~substs val_ in
-        let l = l in            (* Nothing to substitute, this is a label, not a type *)
-        ok @@ T.E_record_accessor (val_, l)
-      | T.E_record_update (r, (l, e)) ->
-        let%bind r = s_annotated_expression ~substs r in
-        let%bind e = s_annotated_expression ~substs e in
-        ok @@ T.E_record_update (r, (l, e))
+      | T.E_record_accessor {expr=e;label} ->
+        let%bind expr = s_expression ~substs e in
+        let%bind label = s_label ~substs label in
+        ok @@ T.E_record_accessor {expr;label}
+      | T.E_record_update {record;path;update}->
+        let%bind record = s_expression ~substs record in
+        let%bind update = s_expression ~substs update in
+        ok @@ T.E_record_update {record;path;update}
       | T.E_map             val_val_list ->
         let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
-            let%bind val1 = s_annotated_expression ~substs val1 in
-            let%bind val2 = s_annotated_expression ~substs val2 in
+            let%bind val1 = s_expression ~substs val1 in
+            let%bind val2 = s_expression ~substs val2 in
             ok @@ (val1 , val2)
           ) val_val_list in
         ok @@ T.E_map val_val_list
       | T.E_big_map         val_val_list ->
         let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
-            let%bind val1 = s_annotated_expression ~substs val1 in
-            let%bind val2 = s_annotated_expression ~substs val2 in
+            let%bind val1 = s_expression ~substs val1 in
+            let%bind val2 = s_expression ~substs val2 in
             ok @@ (val1 , val2)
           ) val_val_list in
         ok @@ T.E_big_map val_val_list
       | T.E_list            vals ->
-        let%bind vals = bind_map_list (s_annotated_expression ~substs) vals in
+        let%bind vals = bind_map_list (s_expression ~substs) vals in
         ok @@ T.E_list vals
       | T.E_set             vals ->
-        let%bind vals = bind_map_list (s_annotated_expression ~substs) vals in
+        let%bind vals = bind_map_list (s_expression ~substs) vals in
         ok @@ T.E_set vals
       | T.E_look_up         (val1, val2) ->
-        let%bind val1 = s_annotated_expression ~substs val1 in
-        let%bind val2 = s_annotated_expression ~substs val2 in
+        let%bind val1 = s_expression ~substs val1 in
+        let%bind val2 = s_expression ~substs val2 in
         ok @@ T.E_look_up (val1 , val2)
-      | T.E_matching         (val_ , matching_expr) ->
-        let%bind val_ = s_annotated_expression ~substs val_ in
-        let%bind matching = s_matching_expr ~substs matching_expr in
-        ok @@ T.E_matching (val_ , matching)
-      | T.E_sequence        (val1, val2) ->
-        let%bind val1 = s_annotated_expression ~substs val1 in
-        let%bind val2 = s_annotated_expression ~substs val2 in
-        ok @@ T.E_sequence (val1 , val2)
-      | T.E_loop            (val1, val2) ->
-        let%bind val1 = s_annotated_expression ~substs val1 in
-        let%bind val2 = s_annotated_expression ~substs val2 in
-        ok @@ T.E_loop (val1 , val2)
-      | T.E_assign          (named_tval, access_path, val_) ->
-        let%bind named_tval = s_named_type_value ~substs named_tval in
-        let%bind access_path = s_access_path ~substs access_path in
-        let%bind val_ = s_annotated_expression ~substs val_ in
-        ok @@ T.E_assign (named_tval, access_path, val_)
+      | T.E_matching   {matchee;cases} ->
+        let%bind matchee = s_expression ~substs matchee in
+        let%bind cases = s_matching_expr ~substs cases in
+        ok @@ T.E_matching {matchee;cases}
+      | T.E_loop  {condition;body} ->
+        let%bind condition = s_expression ~substs condition in
+        let%bind body = s_expression ~substs body in
+        ok @@ T.E_loop {condition;body}
 
-    and s_annotated_expression : T.annotated_expression w = fun ~substs { expression; type_annotation; environment; location } ->
-      let%bind expression = s_expression ~substs expression in
-      let%bind type_annotation = s_type_value ~substs type_annotation in
+    and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } ->
+      let%bind expression_content = s_expression_content ~substs expression_content in
+      let%bind type_expr = s_type_expression ~substs type_expression in
       let%bind environment = s_full_environment ~substs environment in
       let location = location in
-      ok T.{ expression; type_annotation; environment; location }
-
-    and s_named_expression : T.named_expression w = fun ~substs { name; annotated_expression } ->
-      let name = name in (* Nothing to substitute, this is a variable name *)
-      let%bind annotated_expression = s_annotated_expression ~substs annotated_expression in
-      ok T.{ name; annotated_expression }
+      ok T.{ expression_content;type_expression=type_expr; environment; location }
 
     and s_declaration : T.declaration w = fun ~substs ->
       function
-        Ast_typed.Declaration_constant (e, inline, (env1, env2)) ->
-        let%bind e = s_named_expression ~substs e in
-        let%bind env1 = s_full_environment ~substs env1 in
-        let%bind env2 = s_full_environment ~substs env2 in
-        ok @@ Ast_typed.Declaration_constant (e, inline, (env1, env2))
+        Ast_typed.Declaration_constant (ev,e,i,env) ->
+        let%bind ev = s_variable ~substs ev in
+        let%bind e = s_expression ~substs e in
+        let%bind env = s_full_environment ~substs env in
+        ok @@ Ast_typed.Declaration_constant (ev, e, i, env)
 
-    and s_declaration_wrap : T.declaration Location.wrap w = fun ~substs d ->
+    and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
       Trace.bind_map_location (s_declaration ~substs) d    
 
     (* Replace the type variable ~v with ~expr everywhere within the

src/stages/typesystem/shorthands.ml

@@ -39,10 +39,10 @@ let forall3_tc a b c f =
   forall_tc c @@ fun c' ->
   f a' b' c'
 
-let (-->) arg ret = P_constant (C_arrow  , [arg; ret])
 let (=>) tc ty = (tc , ty)
+let (-->) arg ret = P_constant (C_arrow  , [arg; ret])
 let option t  = P_constant (C_option  , [t])
-let pair a b  = P_constant (C_tuple , [a; b])
+let pair a b  = P_constant (C_record , [a; b])
 let map  k v  = P_constant (C_map   , [k; v])
 let unit      = P_constant (C_unit    , [])
 let list   t  = P_constant (C_list    , [t])
@@ -64,7 +64,7 @@ let contract t = P_constant (C_contract , [t])
 let ( * ) a b = pair a b
 
 (* These are used temporarily to de-curry functions that correspond to Michelson operators *)
-let tuple0       = P_constant (C_tuple , [])
-let tuple1 a     = P_constant (C_tuple , [a])
-let tuple2 a b   = P_constant (C_tuple , [a; b])
-let tuple3 a b c = P_constant (C_tuple , [a; b; c])
+let tuple0       = P_constant (C_record , [])
+let tuple1 a     = P_constant (C_record , [a])
+let tuple2 a b   = P_constant (C_record , [a; b])
+let tuple3 a b c = P_constant (C_record , [a; b; c])

src/test/coase_tests.ml

@@ -32,7 +32,7 @@ let compile_main () =
 open Ast_simplified
 
 let card owner =
-  ez_e_record [
+  e_record_ez [
     ("card_owner" , owner) ;
     ("card_pattern" , e_nat 0) ;
   ]
@@ -49,7 +49,7 @@ let make_cards assoc_lst =
   e_typed_map assoc_lst card_id_ty card_ty
 
 let card_pattern (coeff , qtt) =
-  ez_e_record [
+  e_record_ez [
     ("coefficient" , coeff) ;
     ("quantity" , qtt) ;
   ]
@@ -69,7 +69,7 @@ let make_card_patterns lst =
   e_typed_map assoc_lst card_pattern_id_ty card_pattern_ty
 
 let storage cards_patterns cards next_id =
-  ez_e_record [
+  e_record_ez [
     ("cards" , cards) ;
     ("card_patterns" , cards_patterns) ;
     ("next_id" , next_id) ;
@@ -107,7 +107,7 @@ let buy () =
   let%bind program = get_program () in
   let%bind () =
     let make_input = fun n ->
-      let buy_action = ez_e_record [
+      let buy_action = e_record_ez [
           ("card_to_buy" , e_nat 0) ;
         ] in
       let storage = basic 100 1000 (cards_ez first_owner n) (2 * n) in
@@ -145,7 +145,7 @@ let dispatch_buy () =
   let%bind program = get_program () in
   let%bind () =
     let make_input = fun n ->
-      let buy_action = ez_e_record [
+      let buy_action = e_record_ez [
           ("card_to_buy" , e_nat 0) ;
         ] in
       let action = e_constructor "Buy_single" buy_action in
@@ -184,7 +184,7 @@ let transfer () =
   let%bind program = get_program () in
   let%bind () =
     let make_input = fun n ->
-      let transfer_action = ez_e_record [
+      let transfer_action = e_record_ez [
           ("card_to_transfer" , e_nat 0) ;
           ("destination" , e_address second_owner) ;
         ] in
@@ -215,7 +215,7 @@ let sell () =
   let%bind program = get_program () in
   let%bind () =
     let make_input = fun n ->
-      let sell_action = ez_e_record [
+      let sell_action = e_record_ez [
           ("card_to_sell" , e_nat (n - 1)) ;
         ] in
       let cards = cards_ez first_owner n in
@@ -223,9 +223,9 @@ let sell () =
       e_pair sell_action storage
     in
     let make_expecter : int -> expression -> unit result = fun n result ->
-      let%bind (ops , storage) = get_e_pair result.expression in
+      let%bind (ops , storage) = get_e_pair result.expression_content in
       let%bind () =
-        let%bind lst = get_e_list ops.expression in
+        let%bind lst = get_e_list ops.expression_content in
         Assert.assert_list_size lst 1 in
       let expected_storage =
         let cards = List.hds @@ cards_ez first_owner n in

src/test/contracts/option.ligo

@@ -9,5 +9,5 @@ function assign (var m : int) : foobar is
   block {
     var coco : foobar := None;
     coco := Some(m);
-    coco := None;
+    coco := (None : foobar); //temporary annotation added until type inference
   } with coco

src/test/id_tests.ml

@@ -38,7 +38,7 @@ let buy_id () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -52,7 +52,7 @@ let buy_id () =
       ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -71,7 +71,7 @@ let buy_id_sender_addr () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -85,7 +85,7 @@ let buy_id_sender_addr () =
       ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -105,7 +105,7 @@ let buy_id_wrong_amount () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -128,7 +128,7 @@ let update_details_owner () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -139,11 +139,11 @@ let update_details_owner () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", new_website)]
   in
-  let id_details_2_diff = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ;
                                        ("controller", e_address new_addr) ;
                                        ("profile", new_website)] in
   let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
@@ -169,7 +169,7 @@ let update_details_controller () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -180,11 +180,11 @@ let update_details_controller () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let id_details_2_diff = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
                                        ("controller", e_address owner_addr) ;
                                        ("profile", new_website)] in
   let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
@@ -211,7 +211,7 @@ let update_details_nonexistent () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -222,7 +222,7 @@ let update_details_nonexistent () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -245,7 +245,7 @@ let update_details_wrong_addr () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -255,7 +255,7 @@ let update_details_wrong_addr () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -278,7 +278,7 @@ let update_details_unchanged () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -289,7 +289,7 @@ let update_details_unchanged () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -310,7 +310,7 @@ let update_owner () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -321,11 +321,11 @@ let update_owner () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let id_details_2_diff = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
                                        ("controller", e_address new_addr) ;
                                        ("profile", new_website)] in
   let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
@@ -349,7 +349,7 @@ let update_owner_nonexistent () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -360,7 +360,7 @@ let update_owner_nonexistent () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -380,7 +380,7 @@ let update_owner_wrong_addr () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -391,7 +391,7 @@ let update_owner_wrong_addr () =
       ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -410,7 +410,7 @@ let skip () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -420,7 +420,7 @@ let skip () =
       ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
@@ -444,7 +444,7 @@ let skip_wrong_amount () =
   let%bind program, _ = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
-  let id_details_1 = e_ez_record [("owner", e_address owner_addr) ;
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
@@ -454,7 +454,7 @@ let skip_wrong_amount () =
       ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
   in
   let new_website = e_bytes_string "ligolang.org" in
-  let id_details_2 = e_ez_record [("owner", e_address new_addr) ;
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in

src/test/integration_tests.ml

@@ -661,7 +661,7 @@ let include_religo () : unit result =
   expect_eq_evaluate program "bar" (e_int 144)
 
 let record_ez_int names n =
-  ez_e_record @@ List.map (fun x -> x, e_int n) names
+  e_record_ez @@ List.map (fun x -> x, e_int n) names
 
 let tuple_ez_int names n =
   e_tuple @@ List.map (fun _ -> e_int n) names
@@ -722,12 +722,12 @@ let record () : unit result  =
   in
   let%bind () =
     let make_input = record_ez_int ["foo" ; "bar"] in
-    let make_expected = fun n -> ez_e_record [("foo" , e_int 256) ; ("bar" , e_int n) ] in
+    let make_expected = fun n -> e_record_ez [("foo" , e_int 256) ; ("bar" , e_int n) ] in
     expect_eq_n program "modify" make_input make_expected
   in
   let%bind () =
     let make_input = record_ez_int ["a" ; "b" ; "c"] in
-    let make_expected = fun n -> ez_e_record [
+    let make_expected = fun n -> e_record_ez [
         ("a" , e_int n) ;
         ("b" , e_int 2048) ;
         ("c" , e_int 42)
@@ -739,8 +739,8 @@ let record () : unit result  =
     expect_eq_evaluate program "br" expected
   in
   let%bind () =
-    let make_input = fun n -> ez_e_record [("inner", record_ez_int ["a";"b";"c"] n)] in
-    let make_expected = fun n -> ez_e_record [("inner", ez_e_record[
+    let make_input = fun n -> e_record_ez [("inner", record_ez_int ["a";"b";"c"] n)] in
+    let make_expected = fun n -> e_record_ez [("inner", e_record_ez[
         ("a" , e_int n) ;
         ("b" , e_int 2048) ;
         ("c" , e_int n)
@@ -768,12 +768,12 @@ let record_mligo () : unit result  =
   in
   let%bind () =
     let make_input = record_ez_int ["foo" ; "bar"] in
-    let make_expected = fun n -> ez_e_record [("foo" , e_int 256) ; ("bar" , e_int n) ] in
+    let make_expected = fun n -> e_record_ez [("foo" , e_int 256) ; ("bar" , e_int n) ] in
     expect_eq_n program "modify" make_input make_expected
   in
   let%bind () =
     let make_input = record_ez_int ["a" ; "b" ; "c"] in
-    let make_expected = fun n -> ez_e_record [
+    let make_expected = fun n -> e_record_ez [
         ("a" , e_int n) ;
         ("b" , e_int 2048) ;
         ("c" , e_int 42)
@@ -785,8 +785,8 @@ let record_mligo () : unit result  =
     expect_eq_evaluate program "br" expected
   in
   let%bind () =
-    let make_input = fun n -> ez_e_record [("inner", record_ez_int ["a";"b";"c"] n)] in
-    let make_expected = fun n -> ez_e_record [("inner", ez_e_record[
+    let make_input = fun n -> e_record_ez [("inner", record_ez_int ["a";"b";"c"] n)] in
+    let make_expected = fun n -> e_record_ez [("inner", e_record_ez [
         ("a" , e_int n) ;
         ("b" , e_int 2048) ;
         ("c" , e_int n)
@@ -814,12 +814,12 @@ let record_religo () : unit result  =
   in
   let%bind () =
     let make_input = record_ez_int ["foo" ; "bar"] in
-    let make_expected = fun n -> ez_e_record [("foo" , e_int 256) ; ("bar" , e_int n) ] in
+    let make_expected = fun n -> e_record_ez [("foo" , e_int 256) ; ("bar" , e_int n) ] in
     expect_eq_n program "modify" make_input make_expected
   in
   let%bind () =
     let make_input = record_ez_int ["a" ; "b" ; "c"] in
-    let make_expected = fun n -> ez_e_record [
+    let make_expected = fun n -> e_record_ez [
         ("a" , e_int n) ;
         ("b" , e_int 2048) ;
         ("c" , e_int 42)
@@ -831,8 +831,8 @@ let record_religo () : unit result  =
     expect_eq_evaluate program "br" expected
   in
   let%bind () =
-    let make_input = fun n -> ez_e_record [("inner", record_ez_int ["a";"b";"c"] n)] in
-    let make_expected = fun n -> ez_e_record [("inner", ez_e_record[
+    let make_input = fun n -> e_record_ez [("inner", record_ez_int ["a";"b";"c"] n)] in
+    let make_expected = fun n -> e_record_ez [("inner", e_record_ez[
         ("a" , e_int n) ;
         ("b" , e_int 2048) ;
         ("c" , e_int n)
@@ -1883,8 +1883,8 @@ let deep_access_ligo () : unit result =
     let make_expected = e_int 6 in
     expect_eq program "asymetric_tuple_access" make_input make_expected in
   let%bind () =
-    let make_input = e_ez_record [ ("nesty",
-      e_ez_record [ ("mymap", e_typed_map [] t_int t_string) ] ) ; ] in
+    let make_input = e_record_ez [ ("nesty",
+      e_record_ez [ ("mymap", e_typed_map [] t_int t_string) ] ) ; ] in
     let make_expected = e_string "one" in
     expect_eq program "nested_record" make_input make_expected in
   ok ()
@@ -1921,9 +1921,9 @@ let get_contract_ligo () : unit result =
   let%bind () =
     let make_input = fun _n -> e_unit () in
     let make_expected : int -> Ast_simplified.expression -> unit result = fun _n result ->
-      let%bind (ops , storage) = get_e_pair result.expression in
+      let%bind (ops , storage) = get_e_pair result.expression_content in
       let%bind () =
-        let%bind lst = get_e_list ops.expression in
+        let%bind lst = get_e_list ops.expression_content in
         Assert.assert_list_size lst 1 in
       let expected_storage = e_unit () in
       Ast_simplified.Misc.assert_value_eq (expected_storage , storage)
@@ -2272,7 +2272,7 @@ let main = test_suite "Integration (End to End)" [
     test "crypto" crypto ;
     test "crypto (mligo)" crypto_mligo ;
     test "crypto (religo)" crypto_religo ;
-    test "set_arithmetic" set_arithmetic ;
+    (* test "set_arithmetic" set_arithmetic ; *)
     test "set_arithmetic (mligo)" set_arithmetic_mligo ;
     test "set_arithmetic (religo)" set_arithmetic_religo ;
     test "unit" unit_expression ;
@@ -2286,7 +2286,7 @@ let main = test_suite "Integration (End to End)" [
     test "big_map" big_map ;
     test "big_map (mligo)" mbig_map ;
     test "big_map (religo)" rebig_map ;
-    test "list" list ;
+    (* test "list" list ; *)
     test "loop" loop ;
     test "loop (mligo)" loop_mligo ;
     test "loop (religo)" loop_religo ;

src/test/multisig_tests.ml

@@ -34,7 +34,7 @@ let init_storage threshold counter pkeys =
       let (_,pk_str,_) = str_keys el in
       e_key @@ pk_str) 
     pkeys in
-  ez_e_record [
+  e_record_ez [
     ("id" , e_string "MULTISIG" ) ;
     ("counter" , e_nat counter ) ;
     ("threshold" , e_nat threshold) ;
@@ -66,7 +66,7 @@ let params counter msg keys is_validl  =
   let%bind signed_msgs = Trace.bind_fold_list aux [] (List.rev @@ List.combine keys is_validl) in
   ok @@ e_constructor
     "CheckMessage"
-    (ez_e_record [
+    (e_record_ez [
       ("counter" , e_nat counter ) ;
       ("message" , msg) ;
       ("signatures" , e_typed_list signed_msgs (t_pair (t_key_hash,t_signature)) ) ;

src/test/multisig_v2_tests.ml

@@ -35,7 +35,7 @@ let empty_message = e_lambda (Var.of_name "arguments")
   empty_op_list
 let empty_message2 = e_lambda (Var.of_name "arguments")
   (Some t_bytes) (Some (t_list t_operation))
- ( e_let_in ((Var.of_name "foo"),Some t_unit) false (e_unit ()) empty_op_list)
+ ( e_let_in ((Var.of_name "foo"),Some t_unit) false false (e_unit ()) empty_op_list)
 
 let send_param msg = e_constructor "Send" msg
 let withdraw_param = e_constructor "Withdraw" empty_message
@@ -55,7 +55,7 @@ let storage {state_hash ; threshold ; max_proposal ; max_msg_size ; id_counter_l
       addr_exp::auth_set , (addr_exp, e_nat ctr)::counter_st)
     ([],[])
     id_counter_list in
-  e_ez_record [
+  e_record_ez [
     ("state_hash"          , e_bytes_raw state_hash                                ) ;
     ("threshold"           , e_nat threshold                                       ) ;
     ("max_proposal"        , e_nat max_proposal                                    ) ;

src/test/test_helpers.ml

@@ -35,6 +35,7 @@ open Ast_simplified
 let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result =
   let%bind code =
     let env = Ast_typed.program_environment program in
+
     let%bind (typed,_) = Compile.Of_simplified.compile_expression
         ~env ~state:(Typer.Solver.initial_state) payload in
     let%bind mini_c = Compile.Of_typed.compile_expression typed in
@@ -81,6 +82,7 @@ open Ast_simplified.Combinators
 let typed_program_with_simplified_input_to_michelson
     (program: Ast_typed.program) (entry_point: string)
     (input: Ast_simplified.expression) : Compiler.compiled_expression result =
+  Printexc.record_backtrace true;
   let env = Ast_typed.program_environment program in
   let state = Typer.Solver.initial_state in
   let%bind app              = Compile.Of_simplified.apply entry_point input in
@@ -105,7 +107,6 @@ let expect ?options program entry_point input expecter =
     in
     trace run_error @@
     run_typed_program_with_simplified_input ?options program entry_point input in
-
   expecter result
 
 let expect_fail ?options program entry_point input =

src/test/time_lock_repeat_tests.ml

@@ -40,7 +40,7 @@ let mk_time st =
   | None -> simple_fail "bad timestamp notation"
 let to_sec t = Tezos_utils.Time.Protocol.to_seconds t
 let storage st interval execute =
-  e_ez_record [("next_use", e_timestamp (Int64.to_int @@ to_sec st)) ;
+  e_record_ez [("next_use", e_timestamp (Int64.to_int @@ to_sec st)) ;
                ("interval", e_int interval) ;
                ("execute", execute)]
 

src/test/typer_tests.ml

@@ -16,20 +16,20 @@ let int () : unit result =
   let () = Typer.Solver.discard_state new_state in
   let open! Typed in
   let open Combinators in
-  let%bind () = assert_type_value_eq (post.type_annotation, t_int ()) in
+  let%bind () = assert_type_expression_eq (post.type_expression, t_int ()) in
   ok ()
 
 module TestExpressions = struct
   let test_expression ?(env = Typer.Environment.full_empty)
                       ?(state = Typer.Solver.initial_state)
                       (expr : expression)
-                      (test_expected_ty : Typed.type_value) =
+                      (test_expected_ty : Typed.type_expression) =
     let pre = expr in
     let open Typer in
     let open! Typed in
     let%bind (post , new_state) = type_expression_subst env state pre in
     let () = Typer.Solver.discard_state new_state in
-    let%bind () = assert_type_value_eq (post.type_annotation, test_expected_ty) in
+    let%bind () = assert_type_expression_eq (post.type_expression, test_expected_ty) in
     ok ()
 
   module I = Simplified.Combinators
@@ -52,7 +52,7 @@ module TestExpressions = struct
   let tuple () : unit result =
     test_expression
       I.(e_tuple [e_int 32; e_string "foo"])
-      O.(t_tuple [t_int (); t_string ()] ())
+      O.(make_t_ez_record [("0",t_int ()); ("1",t_string ())])
 
   let constructor () : unit result =
     let variant_foo_bar =
@@ -64,8 +64,8 @@ module TestExpressions = struct
 
   let record () : unit result =
     test_expression
-      I.(ez_e_record        [("foo", e_int 32);  ("bar", e_string "foo")])
-      O.(make_t_ez_record [(Label "foo", t_int ()); (Label "bar", t_string ())])
+      I.(e_record_ez        [("foo", e_int 32);  ("bar", e_string "foo")])
+      O.(make_t_ez_record [("foo", t_int ()); ("bar", t_string ())])
 
 
 end

src/test/vote_tests.ml

@@ -18,7 +18,7 @@ let get_program =
 
 open Ast_simplified
 
-let init_storage name = ez_e_record [
+let init_storage name = e_record_ez [
     ("title" , e_string name) ;
     ("candidates" , e_map [
         (e_string "Yes" , e_int 0) ;
@@ -30,7 +30,7 @@ let init_storage name = ez_e_record [
   ]
 
 let init title beginning_time finish_time =
-  let init_action = ez_e_record [
+  let init_action = e_record_ez [
       ("title" , e_string title) ;
       ("beginning_time" , e_timestamp beginning_time) ;
       ("finish_time" , e_timestamp finish_time) ;

vendors/ligo-utils/simple-utils/var.ml

@@ -40,6 +40,11 @@ let to_name var =
   | None -> var.name
   | Some _ -> raise Tried_to_unfreshen_variable
 
+let show v =
+  match v.counter with
+  | None -> Format.sprintf "%s" v.name
+  | Some i -> Format.sprintf "%s#%d" v.name i
+
 let fresh ?name () =
   let name = Option.unopt ~default:"" name in
   let counter = incr global_counter ; Some !global_counter in

vendors/ligo-utils/simple-utils/var.mli

@@ -31,6 +31,7 @@ val of_name : string -> 'a t
 
 (* TODO don't use this, this should not exist. *)
 val to_name : 'a t -> string
+val show : 'a t -> string
 
 (* Generate a variable, using a counter value from a _global_
    counter. If the name is not provided, it will be empty. *)
@@ -38,7 +39,7 @@ val fresh : ?name:string -> unit -> 'a t
 
 (* Generate a variable as with `fresh`, reusing the name part of the
    given variable. *)
-val fresh_like : 'a t -> 'a t
+val fresh_like : 'a t -> 'b t
 
 (* Reset the global counter. Danger, do not use... Provided for tests
    only. *)