Feature/transpiler

src/bin/cli.ml

@@ -139,7 +139,7 @@ let optimize =
 
 module Helpers   = Ligo.Compile.Helpers
 module Compile   = Ligo.Compile
-module Uncompile = Ligo.Uncompile
+module Decompile = Ligo.Decompile
 module Run = Ligo.Run.Of_michelson
 
 let compile_file =
@@ -285,7 +285,7 @@ let compile_parameter =
 
 let interpret =
   let f expression init_file syntax amount balance sender source predecessor_timestamp display_format =
-    return_result ~display_format (Uncompile.Formatter.expression_format) @@
+    return_result ~display_format (Decompile.Formatter.expression_format) @@
       let%bind (decl_list,state,env) = match init_file with
         | Some init_file ->
           let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
@@ -299,7 +299,7 @@ let interpret =
       let%bind compiled_exp   = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in
       let%bind options        = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres         = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
-      Uncompile.uncompile_expression typed_exp.type_expression runres
+      Decompile.Of_michelson.decompile_expression typed_exp.type_expression runres
   in
   let term =
     Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
@@ -345,7 +345,7 @@ let compile_storage =
 
 let dry_run =
   let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
-    return_result ~display_format (Uncompile.Formatter.expression_format) @@
+    return_result ~display_format (Decompile.Formatter.expression_format) @@
       let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
       let      env             = Ast_typed.program_environment Environment.default typed_prg in
       let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
@@ -359,7 +359,7 @@ let dry_run =
 
       let%bind options           = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres  = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
-      Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
+      Decompile.Of_michelson.decompile_typed_program_entry_function_result typed_prg entry_point runres
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@@ -369,7 +369,7 @@ let dry_run =
 
 let run_function =
   let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
-    return_result ~display_format (Uncompile.Formatter.expression_format) @@
+    return_result ~display_format (Decompile.Formatter.expression_format) @@
       let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
       let      env             = Ast_typed.program_environment Environment.default typed_prg in
       let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
@@ -386,7 +386,7 @@ let run_function =
       let%bind michelson        = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
       let%bind options          = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres           = Run.run_expression ~options michelson.expr michelson.expr_ty in
-      Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point runres
+      Decompile.Of_michelson.decompile_typed_program_entry_function_result typed_prg entry_point runres
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@@ -396,14 +396,14 @@ let run_function =
 
 let evaluate_value =
   let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
-    return_result ~display_format Uncompile.Formatter.expression_format @@
+    return_result ~display_format Decompile.Formatter.expression_format @@
       let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
       let%bind mini_c      = Compile.Of_typed.compile typed_prg in
       let%bind (exp,_)     = trace_option Main_errors.entrypoint_not_found @@ Mini_c.get_entry mini_c entry_point in
       let%bind compiled    = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
       let%bind options     = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
       let%bind runres      = Run.run_expression ~options compiled.expr compiled.expr_ty in
-      Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point runres
+      Decompile.Of_michelson.decompile_typed_program_entry_expression_result typed_prg entry_point runres
     in
   let term =
     Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@@ -449,6 +449,41 @@ let list_declarations =
   let doc = "Subcommand: List all the top-level declarations." in
   (Term.ret term , Term.info ~doc cmdname)
 
+let transpile_contract =
+  let f source_file new_syntax syntax display_format =
+    return_result ~display_format (Parser.Formatter.ppx_format) @@
+      let%bind core       = Compile.Utils.to_core source_file syntax in
+      let%bind sugar      = Decompile.Of_core.decompile core in
+      let%bind imperative = Decompile.Of_sugar.decompile sugar in
+      let%bind buffer     = Decompile.Of_imperative.decompile imperative (Syntax_name new_syntax) in
+      ok @@ buffer
+  in
+  let term =
+    Term.(const f $ source_file 0 $ req_syntax 1 $ syntax $ display_format) in
+  let cmdname = "transpile-contract" in
+  let doc = "Subcommand: Transpile a contract to another syntax." in
+  (Term.ret term , Term.info ~doc cmdname)
+
+let transpile_expression =
+  let f expression new_syntax syntax display_format =
+    return_result ~display_format (Parser.Formatter.ppx_format) @@
+      let%bind v_syntax   = Helpers.syntax_to_variant (Syntax_name syntax) None in
+      let%bind n_syntax   = Decompile.Helpers.syntax_to_variant (Syntax_name new_syntax) None in
+      let%bind imperative = Compile.Of_source.compile_expression v_syntax expression in
+      let%bind sugar      = Compile.Of_imperative.compile_expression imperative in
+      let%bind core       = Compile.Of_sugar.compile_expression sugar in
+      let%bind sugar      = Decompile.Of_core.decompile_expression core in
+      let%bind imperative = Decompile.Of_sugar.decompile_expression sugar in
+      let%bind buffer     = Decompile.Of_imperative.decompile_expression imperative n_syntax in
+      ok @@ buffer
+  in
+  let term =
+    Term.(const f $ expression "" 1  $ req_syntax 2 $ req_syntax 0 $ display_format) in
+  let cmdname = "transpile-expression" in
+  let doc = "Subcommand: Transpile an expression to another syntax." in
+  (Term.ret term , Term.info ~doc cmdname)
+
+
 let run ?argv () =
   Term.eval_choice ?argv main [
     temp_ligo_interpreter ;
@@ -457,6 +492,8 @@ let run ?argv () =
     compile_parameter ;
     compile_storage ;
     compile_expression ;
+    transpile_contract ;
+    transpile_expression ;
     interpret ;
     dry_run ;
     run_function ;

src/bin/expect_tests/help_tests.ml

@@ -87,6 +87,12 @@ let%expect_test _ =
            run-function
                Subcommand: Run a function with the given parameter.
 
+           transpile-contract
+               Subcommand: Transpile a contract to another syntax.
+
+           transpile-expression
+               Subcommand: Transpile an expression to another syntax.
+
     OPTIONS
            --help[=FMT] (default=auto)
                Show this help in format FMT. The value FMT must be one of `auto',
@@ -181,6 +187,12 @@ let%expect_test _ =
            run-function
                Subcommand: Run a function with the given parameter.
 
+           transpile-contract
+               Subcommand: Transpile a contract to another syntax.
+
+           transpile-expression
+               Subcommand: Transpile an expression to another syntax.
+
     OPTIONS
            --help[=FMT] (default=auto)
                Show this help in format FMT. The value FMT must be one of `auto',

src/main/compile/helpers.ml

@@ -18,97 +18,97 @@ let syntax_to_variant (Syntax_name syntax) source =
   | _ -> fail (invalid_syntax syntax) 
 
 
-let parsify_pascaligo source =
+let parse_and_abstract_pascaligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Pascaligo.parse_file source in
   let%bind imperative = trace cit_pascaligo_tracer @@
     Tree_abstraction.Pascaligo.compile_program raw
   in ok imperative
 
-let parsify_expression_pascaligo source =
+let parse_and_abstract_expression_pascaligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Pascaligo.parse_expression source in
   let%bind imperative = trace cit_pascaligo_tracer @@
     Tree_abstraction.Pascaligo.compile_expression raw
   in ok imperative
 
-let parsify_cameligo source =
+let parse_and_abstract_cameligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Cameligo.parse_file source in
   let%bind imperative = trace cit_cameligo_tracer @@
     Tree_abstraction.Cameligo.compile_program raw
   in ok imperative
 
-let parsify_expression_cameligo source =
+let parse_and_abstract_expression_cameligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Cameligo.parse_expression source in
   let%bind imperative = trace cit_cameligo_tracer @@
     Tree_abstraction.Cameligo.compile_expression raw
   in ok imperative
 
-let parsify_reasonligo source =
+let parse_and_abstract_reasonligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Reasonligo.parse_file source in
   let%bind imperative = trace cit_cameligo_tracer @@
     Tree_abstraction.Cameligo.compile_program raw
   in ok imperative
 
-let parsify_expression_reasonligo source =
+let parse_and_abstract_expression_reasonligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Reasonligo.parse_expression source in
   let%bind imperative = trace cit_cameligo_tracer @@
     Tree_abstraction.Cameligo.compile_expression raw
   in ok imperative
 
-let parsify syntax source : (Ast_imperative.program, _) Trace.result =
+let parse_and_abstract syntax source : (Ast_imperative.program, _) Trace.result =
-  let%bind parsify =
+  let%bind parse_and_abstract =
     match syntax with
-      PascaLIGO  -> ok parsify_pascaligo
+      PascaLIGO  -> ok parse_and_abstract_pascaligo
-    | CameLIGO   -> ok parsify_cameligo
+    | CameLIGO   -> ok parse_and_abstract_cameligo
-    | ReasonLIGO -> ok parsify_reasonligo in
+    | ReasonLIGO -> ok parse_and_abstract_reasonligo in
-  let%bind parsified = parsify source in
+  let%bind parsified = parse_and_abstract source in
   let%bind applied = trace self_ast_imperative_tracer @@
     Self_ast_imperative.all_program parsified in
   ok applied
 
-let parsify_expression syntax source =
+let parse_and_abstract_expression syntax source =
-  let%bind parsify = match syntax with
+  let%bind parse_and_abstract = match syntax with
-    PascaLIGO  -> ok parsify_expression_pascaligo
+    PascaLIGO  -> ok parse_and_abstract_expression_pascaligo
-  | CameLIGO   -> ok parsify_expression_cameligo
+  | CameLIGO   -> ok parse_and_abstract_expression_cameligo
-  | ReasonLIGO -> ok parsify_expression_reasonligo in
+  | ReasonLIGO -> ok parse_and_abstract_expression_reasonligo in
-  let%bind parsified = parsify source in
+  let%bind parsified = parse_and_abstract source in
   let%bind applied = trace self_ast_imperative_tracer @@
     Self_ast_imperative.all_expression parsified
   in ok applied
 
-let parsify_string_reasonligo source =
+let parse_and_abstract_string_reasonligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Reasonligo.parse_string source in
   let%bind imperative = trace cit_cameligo_tracer @@
     Tree_abstraction.Cameligo.compile_program raw
   in ok imperative
 
-let parsify_string_pascaligo source =
+let parse_and_abstract_string_pascaligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Pascaligo.parse_string source in
   let%bind imperative = trace cit_pascaligo_tracer @@
     Tree_abstraction.Pascaligo.compile_program raw
   in ok imperative
 
-let parsify_string_cameligo source =
+let parse_and_abstract_string_cameligo source =
   let%bind raw = trace parser_tracer @@
     Parser.Cameligo.parse_string source in
   let%bind imperative = trace cit_cameligo_tracer @@
     Tree_abstraction.Cameligo.compile_program raw
   in ok imperative
 
-let parsify_string syntax source =
+let parse_and_abstract_string syntax source =
-  let%bind parsify =
+  let%bind parse_and_abstract =
     match syntax with
-      PascaLIGO  -> ok parsify_string_pascaligo
+      PascaLIGO  -> ok parse_and_abstract_string_pascaligo
-    | CameLIGO   -> ok parsify_string_cameligo
+    | CameLIGO   -> ok parse_and_abstract_string_cameligo
-    | ReasonLIGO -> ok parsify_string_reasonligo in
+    | ReasonLIGO -> ok parse_and_abstract_string_reasonligo in
-  let%bind parsified = parsify source in
+  let%bind parsified = parse_and_abstract source in
   let%bind applied = trace self_ast_imperative_tracer @@
     Self_ast_imperative.all_program parsified
   in ok applied

src/main/compile/of_core.ml

@@ -24,10 +24,12 @@ let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem
 let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result =
   let name = Var.of_name entry_point in
   let entry_point_var : Ast_core.expression =
-    { expression_content = Ast_core.E_variable name ;
+    { content  = Ast_core.E_variable name ;
+      sugar    = None ;
       location = Virtual "generated entry-point variable" } in
   let applied : Ast_core.expression = 
-    { expression_content = Ast_core.E_application {lamb=entry_point_var; args=param} ;
+    { content  = Ast_core.E_application {lamb=entry_point_var; args=param} ;
+      sugar    = None ;
       location = Virtual "generated application" } in
   ok applied
 

src/main/compile/of_imperative.ml

@@ -3,10 +3,6 @@ open Trace
 open Ast_imperative
 open Purification
 
-type form = 
-  | Contract of string
-  | Env
-
 let compile (program : program) : (Ast_sugar.program, _) result =
   trace purification_tracer @@ compile_program program
 

src/main/compile/of_source.ml

@@ -3,16 +3,16 @@ open Helpers
 
 let compile (source_filename:string) syntax : (Ast_imperative.program , _) result =
   let%bind syntax = syntax_to_variant syntax (Some source_filename) in
-  let%bind abstract = parsify syntax source_filename in
+  let%bind abstract = parse_and_abstract syntax source_filename in
   ok abstract
 
 let compile_string (source:string) syntax : (Ast_imperative.program , _) result =
-  let%bind abstract = parsify_string syntax source in
+  let%bind abstract = parse_and_abstract_string syntax source in
   ok abstract
 
 let compile_expression : v_syntax -> string -> (Ast_imperative.expression , _) result =
     fun syntax exp ->
-  parsify_expression syntax exp
+  parse_and_abstract_expression syntax exp
 
 let compile_contract_input : string -> string -> v_syntax -> (Ast_imperative.expression , _) result =
     fun storage parameter syntax ->

src/main/compile/of_sugar.ml

@@ -3,10 +3,6 @@ open Ast_sugar
 open Desugaring
 open Main_errors
 
-type form = 
-  | Contract of string
-  | Env
-
 let compile (program : program) : (Ast_core.program , _) result =
   trace desugaring_tracer @@ compile_program program
 

src/main/decompile/dune

@@ -1,17 +1,30 @@
 (library
-  (name uncompile)
+  (name decompile)
-  (public_name ligo.uncompile)
+  (public_name ligo.decompile)
   (libraries
+    main_errors
     simple-utils
+    tezos-utils
+    parser
+    tree_abstraction
+    ast_imperative
+    self_ast_imperative
     purification
+    ast_sugar
+    self_ast_sugar
     desugaring
+    ast_core
+    self_ast_core
     typer_new
     typer
     ast_typed
+    self_ast_typed
+    interpreter
     spilling
     mini_c
+    self_mini_c
     stacking
-    main_errors
+    self_michelson
   )
   (preprocess
     (pps ppx_let bisect_ppx --conditional)

src/main/decompile/helpers.ml

@@ -0,0 +1,78 @@
+open Trace
+open Main_errors
+
+type s_syntax = Syntax_name of string
+type v_syntax = PascaLIGO | CameLIGO | ReasonLIGO
+
+let syntax_to_variant (Syntax_name syntax) source =
+  match syntax, source with
+    "auto", Some sf ->
+      (match Filename.extension sf with
+         ".ligo" | ".pligo" -> ok PascaLIGO
+       | ".mligo"           -> ok CameLIGO
+       | ".religo"          -> ok ReasonLIGO
+       | ext                -> fail (syntax_auto_detection ext))
+  | ("pascaligo" | "PascaLIGO"),   _ -> ok PascaLIGO
+  | ("cameligo" | "CameLIGO"),     _ -> ok CameLIGO
+  | ("reasonligo" | "ReasonLIGO"), _ -> ok ReasonLIGO
+  | _ -> fail (invalid_syntax syntax) 
+
+let specialise_and_print_pascaligo program =
+  let%bind cst = trace cit_pascaligo_tracer @@
+    Tree_abstraction.Pascaligo.decompile_program program in
+  let%bind source = trace pretty_tracer @@
+    Parser.Pascaligo.pretty_print cst
+  in ok source
+
+let specialise_and_print_expression_pascaligo expression =
+  let%bind cst = trace cit_pascaligo_tracer @@
+    Tree_abstraction.Pascaligo.decompile_expression expression in
+  let%bind source = trace pretty_tracer @@
+    Parser.Pascaligo.pretty_print_expression cst
+  in ok source
+
+let specialise_and_print_cameligo program =
+  let%bind cst = trace cit_cameligo_tracer @@
+    Tree_abstraction.Cameligo.decompile_program program in
+  let%bind source = trace pretty_tracer @@
+    Parser.Cameligo.pretty_print cst
+  in ok source
+
+let specialise_and_print_expression_cameligo expression =
+  let%bind cst = trace cit_cameligo_tracer @@
+    Tree_abstraction.Cameligo.decompile_expression expression in
+  let%bind source = trace pretty_tracer @@
+    Parser.Cameligo.pretty_print_expression cst
+  in ok source
+
+let specialise_and_print_reasonligo program =
+  let%bind cst = trace cit_cameligo_tracer @@
+    Tree_abstraction.Cameligo.decompile_program program in
+  let%bind source = trace pretty_tracer @@
+    Parser.Reasonligo.pretty_print cst
+  in ok source
+
+let specialise_and_print_expression_reasonligo expression =
+  let%bind cst = trace cit_cameligo_tracer @@
+    Tree_abstraction.Cameligo.decompile_expression expression in
+  let%bind source = trace pretty_tracer @@
+    Parser.Reasonligo.pretty_print_expression cst
+  in ok source
+
+
+let specialise_and_print syntax source : (Buffer.t, _) Trace.result =
+  let%bind specialise_and_print =
+    match syntax with
+      PascaLIGO  -> ok specialise_and_print_pascaligo
+    | CameLIGO   -> ok specialise_and_print_cameligo
+    | ReasonLIGO -> ok specialise_and_print_reasonligo in
+  let%bind source = specialise_and_print source in
+  ok source
+
+let specialise_and_print_expression syntax source =
+  let%bind specialise_and_print = match syntax with
+    PascaLIGO  -> ok specialise_and_print_expression_pascaligo
+  | CameLIGO   -> ok specialise_and_print_expression_cameligo
+  | ReasonLIGO -> ok specialise_and_print_expression_reasonligo in
+  let%bind source = specialise_and_print source in
+  ok source

src/main/decompile/of_core.ml

@@ -0,0 +1,10 @@
+open Trace
+open Ast_core
+open Desugaring
+open Main_errors
+
+let decompile (program : program) : (Ast_sugar.program , _) result =
+  trace sugaring_tracer @@ decompile_program program
+
+let decompile_expression (e : expression) : (Ast_sugar.expression , _) result =
+  trace sugaring_tracer @@ decompile_expression e

src/main/decompile/of_imperative.ml

@@ -0,0 +1,10 @@
+open Trace
+open Ast_imperative
+open Helpers
+
+let decompile (program : program) syntax : (_ , _) result =
+  let%bind syntax = syntax_to_variant syntax None in
+  specialise_and_print syntax program
+
+let decompile_expression (e : expression) syntax : (_ , _) result =
+  specialise_and_print_expression syntax e

src/main/decompile/of_michelson.ml

@@ -5,7 +5,7 @@ open Trace
 open Simple_utils.Runned_result
 
 type ret_type = Function | Expression
-let uncompile_value func_or_expr program entry ex_ty_value =
+let decompile_value func_or_expr program entry ex_ty_value =
   let%bind output_type =
     let%bind entry_expression = trace_option entrypoint_not_found @@ Ast_typed.get_entry program entry in
     match func_or_expr with
@@ -14,30 +14,30 @@ let uncompile_value func_or_expr program entry ex_ty_value =
     | Function ->
       let%bind (_,output_type) = trace_option entrypoint_not_a_function @@ Ast_typed.get_t_function entry_expression.type_expression in
       ok output_type in
-  let%bind mini_c = trace uncompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
+  let%bind mini_c = trace decompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
-  let%bind typed =  trace uncompile_mini_c    @@ Spilling.decompile mini_c output_type in
+  let%bind typed =  trace decompile_mini_c    @@ Spilling.decompile mini_c output_type in
-  let%bind core  =  trace uncompile_typed     @@ Typer.untype_expression typed in
+  let%bind core  =  trace decompile_typed     @@ Typer.untype_expression typed in
   ok @@ core
 
-let uncompile_typed_program_entry_expression_result program entry runned_result =
+let decompile_typed_program_entry_expression_result program entry runned_result =
   match runned_result with
   | Fail s -> ok (Fail s)
   | Success ex_ty_value ->
-    let%bind uncompiled_value = uncompile_value Expression program entry ex_ty_value in
+    let%bind decompiled_value = decompile_value Expression program entry ex_ty_value in
-    ok (Success uncompiled_value)
+    ok (Success decompiled_value)
 
-let uncompile_typed_program_entry_function_result program entry runned_result =
+let decompile_typed_program_entry_function_result program entry runned_result =
   match runned_result with
   | Fail s -> ok (Fail s)
   | Success ex_ty_value ->
-    let%bind uncompiled_value = uncompile_value Function program entry ex_ty_value in
+    let%bind decompiled_value = decompile_value Function program entry ex_ty_value in
-    ok (Success uncompiled_value)
+    ok (Success decompiled_value)
 
-let uncompile_expression type_value runned_result =
+let decompile_expression type_value runned_result =
   match runned_result with
   | Fail s -> ok (Fail s)
   | Success ex_ty_value ->
-    let%bind mini_c = trace uncompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
+    let%bind mini_c = trace decompile_michelson @@ Stacking.Decompiler.decompile_value ex_ty_value in
-    let%bind typed = trace uncompile_mini_c @@ Spilling.decompile mini_c type_value in
+    let%bind typed = trace decompile_mini_c @@ Spilling.decompile mini_c type_value in
-    let%bind uncompiled_value = trace uncompile_typed @@ Typer.untype_expression typed in
+    let%bind decompiled_value = trace decompile_typed @@ Typer.untype_expression typed in
-    ok (Success uncompiled_value)
+    ok (Success decompiled_value)

src/main/decompile/of_sugar.ml

@@ -0,0 +1,10 @@
+open Trace
+open Ast_sugar
+open Purification
+open Main_errors
+
+let decompile (program : program) : (Ast_imperative.program , _) result =
+  trace depurification_tracer @@ decompile_program program
+
+let decompile_expression (e : expression) : (Ast_imperative.expression , _) result =
+  trace depurification_tracer @@ decompile_expression e

src/main/dune

@@ -4,7 +4,7 @@
   (libraries
     run
     compile
-    uncompile
+    decompile
     main_errors
   )
   (preprocess

src/main/main.ml

@@ -1,5 +1,5 @@
 module Run = Run
 module Compile   = Compile
-module Uncompile = Uncompile
+module Decompile = Decompile
 module Display = Display
 module Formatter = Main_errors.Formatter

src/main/main_errors/formatter.ml

@@ -121,9 +121,12 @@ let rec error_ppformat' : display_format:string display_format ->
     | `Main_michelson_execution_error _ -> Format.fprintf f "@[<hv>Error of execution@]"
 
     | `Main_parser e -> Parser.Errors.error_ppformat ~display_format f e
+    | `Main_pretty _e -> () (*no error in this pass*)
     | `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_ppformat ~display_format f e 
     | `Main_purification e -> Purification.Errors.error_ppformat ~display_format f e
+    | `Main_depurification _e -> () (*no error in this pass*)
     | `Main_desugaring _e -> () (*no error in this pass*)
+    | `Main_sugaring _e -> () (*no error in this pass*)
     | `Main_cit_pascaligo e -> Tree_abstraction.Pascaligo.Errors.error_ppformat ~display_format f e
     | `Main_cit_cameligo e -> Tree_abstraction.Cameligo.Errors.error_ppformat ~display_format f e
     | `Main_typer e -> Typer.Errors.error_ppformat ~display_format f e
@@ -133,9 +136,9 @@ let rec error_ppformat' : display_format:string display_format ->
     | `Main_spilling e -> Spilling.Errors.error_ppformat ~display_format f  e
     | `Main_stacking e -> Stacking.Errors.error_ppformat ~display_format f e
 
-    | `Main_uncompile_michelson e -> Stacking.Errors.error_ppformat ~display_format f  e
+    | `Main_decompile_michelson e -> Stacking.Errors.error_ppformat ~display_format f  e
-    | `Main_uncompile_mini_c e -> Spilling.Errors.error_ppformat ~display_format f  e
+    | `Main_decompile_mini_c e -> Spilling.Errors.error_ppformat ~display_format f  e
-    | `Main_uncompile_typed e -> Typer.Errors.error_ppformat ~display_format f  e
+    | `Main_decompile_typed e -> Typer.Errors.error_ppformat ~display_format f  e
   )
   
 let error_ppformat : display_format:string display_format ->
@@ -272,9 +275,12 @@ let rec error_jsonformat : Types.all -> J.t = fun a ->
   | `Main_entrypoint_not_found -> json_error ~stage:"top-level glue" ~content:(`String "Missing entrypoint")
 
   | `Main_parser e -> Parser.Errors.error_jsonformat e
+  | `Main_pretty _ -> `Null (*no error in this pass*)
   | `Main_self_ast_imperative e -> Self_ast_imperative.Errors.error_jsonformat e
   | `Main_purification e -> Purification.Errors.error_jsonformat e
+  | `Main_depurification _ -> `Null (*no error in this pass*)
   | `Main_desugaring _ -> `Null (*no error in this pass*)
+  | `Main_sugaring _ -> `Null (*no error in this pass*)
   | `Main_cit_pascaligo e -> Tree_abstraction.Pascaligo.Errors.error_jsonformat e
   | `Main_cit_cameligo e -> Tree_abstraction.Cameligo.Errors.error_jsonformat e
   | `Main_typer e -> Typer.Errors.error_jsonformat e
@@ -284,9 +290,9 @@ let rec error_jsonformat : Types.all -> J.t = fun a ->
   | `Main_self_mini_c e -> Self_mini_c.Errors.error_jsonformat e
   | `Main_stacking e -> Stacking.Errors.error_jsonformat e
   
-  | `Main_uncompile_michelson e -> Stacking.Errors.error_jsonformat e
+  | `Main_decompile_michelson e -> Stacking.Errors.error_jsonformat e
-  | `Main_uncompile_mini_c e -> Spilling.Errors.error_jsonformat e
+  | `Main_decompile_mini_c e -> Spilling.Errors.error_jsonformat e
-  | `Main_uncompile_typed e -> Typer.Errors.error_jsonformat e
+  | `Main_decompile_typed e -> Typer.Errors.error_jsonformat e
 
 let error_format : _ Display.format = {
   pp = error_ppformat;

src/main/main_errors/main_errors.ml

@@ -5,11 +5,14 @@ type all = Types.all
 (* passes tracers *)
 
 let parser_tracer (e:Parser.Errors.parser_error) : all = `Main_parser e
+let pretty_tracer (e:Parser.Errors.parser_error) : all = `Main_pretty e
 let cit_cameligo_tracer (e:Tree_abstraction.Cameligo.Errors.abs_error) : all = `Main_cit_cameligo e
 let cit_pascaligo_tracer (e:Tree_abstraction.Pascaligo.Errors.abs_error) : all = `Main_cit_pascaligo e
 let self_ast_imperative_tracer (e:Self_ast_imperative.Errors.self_ast_imperative_error) : all = `Main_self_ast_imperative e
 let purification_tracer (e:Purification.Errors.purification_error) : all = `Main_purification e
+let depurification_tracer (e:Purification.Errors.purification_error) : all = `Main_depurification e
 let desugaring_tracer (e:Desugaring.Errors.desugaring_error) : all = `Main_desugaring e
+let sugaring_tracer (e:Desugaring.Errors.desugaring_error) : all = `Main_sugaring e
 let typer_tracer (e:Typer.Errors.typer_error) : all = `Main_typer e
 let self_ast_typed_tracer (e:Self_ast_typed.Errors.self_ast_typed_error) : all = `Main_self_ast_typed e
 let self_mini_c_tracer (e:Self_mini_c.Errors.self_mini_c_error) : all = `Main_self_mini_c e
@@ -17,9 +20,9 @@ let spilling_tracer (e:Spilling.Errors.spilling_error) : all = `Main_spilling e
 let stacking_tracer (e:Stacking.Errors.stacking_error) : all = `Main_stacking e
 let interpret_tracer (e:Interpreter.interpreter_error) : all = `Main_interpreter e
 
-let uncompile_mini_c : Spilling.Errors.spilling_error -> all = fun e -> `Main_uncompile_mini_c e
+let decompile_mini_c : Spilling.Errors.spilling_error -> all = fun e -> `Main_decompile_mini_c e
-let uncompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_uncompile_typed e
+let decompile_typed : Typer.Errors.typer_error -> all = fun e -> `Main_decompile_typed e
-let uncompile_michelson : Stacking.Errors.stacking_error -> all = fun e -> `Main_uncompile_michelson e
+let decompile_michelson : Stacking.Errors.stacking_error -> all = fun e -> `Main_decompile_michelson e
 
 (* top-level glue (in between passes) *)
 

src/main/main_errors/types.ml

@@ -21,9 +21,12 @@ type all =
  | `Main_michelson_execution_error of Proto_alpha_utils.Trace.tezos_alpha_error list
 
  | `Main_parser of Parser.Errors.parser_error
+ | `Main_pretty of Parser.Errors.parser_error
  | `Main_self_ast_imperative of Self_ast_imperative.Errors.self_ast_imperative_error
  | `Main_purification   of Purification.Errors.purification_error
+ | `Main_depurification of Purification.Errors.purification_error
  | `Main_desugaring of Desugaring.Errors.desugaring_error
+ | `Main_sugaring   of Desugaring.Errors.desugaring_error
  | `Main_cit_pascaligo of Tree_abstraction.Pascaligo.Errors.abs_error
  | `Main_cit_cameligo of Tree_abstraction.Cameligo.Errors.abs_error
  | `Main_typer of Typer.Errors.typer_error
@@ -33,9 +36,9 @@ type all =
  | `Main_spilling of Spilling.Errors.spilling_error
  | `Main_stacking of Stacking.Errors.stacking_error
 
- | `Main_uncompile_michelson of Stacking.Errors.stacking_error
+ | `Main_decompile_michelson of Stacking.Errors.stacking_error
- | `Main_uncompile_mini_c of Spilling.Errors.spilling_error
+ | `Main_decompile_mini_c of Spilling.Errors.spilling_error
- | `Main_uncompile_typed of Typer.Errors.typer_error
+ | `Main_decompile_typed of Typer.Errors.typer_error
  | `Main_entrypoint_not_a_function
  | `Main_entrypoint_not_found
  | `Main_invalid_amount of string

src/passes/01-parsing/cameligo.ml

@@ -145,11 +145,24 @@ let preprocess source = apply (fun () -> Unit.preprocess source)
 
 (* Pretty-print a file (after parsing it). *)
 
-let pretty_print source =
+let pretty_print cst =
-  match parse_file source with
+  let doc    = Pretty.print cst in
-    Stdlib.Error _ as e -> e
+  let buffer = Buffer.create 131 in
-  | Ok ast ->
+  let width  =
-      let doc    = Pretty.print (fst ast) in
+    match Terminal_size.get_columns () with
+      None -> 60
+    | Some c -> c in
+  let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
+  in Trace.ok buffer
+
+let pretty_print_from_source source =
+  match parse_file source with
+    Stdlib.Error _ as e -> e
+  | Ok cst ->
+    pretty_print @@ fst cst
+
+let pretty_print_expression cst =
+  let doc    = Pretty.pp_expr cst in
   let buffer = Buffer.create 131 in
   let width  =
     match Terminal_size.get_columns () with

src/passes/01-parsing/cameligo.mli

@@ -22,4 +22,9 @@ val parse_expression : string -> (CST.expr , Errors.parser_error) result
 val preprocess : string -> (Buffer.t , Errors.parser_error) result
 
 (** Pretty-print a given CameLIGO file (after parsing it). *)
-val pretty_print : string -> (Buffer.t, Errors.parser_error) result
+val pretty_print_from_source : string -> (Buffer.t, Errors.parser_error) result
+
+(** Take a CameLIGO cst and pretty_print it *)
+val pretty_print : CST.t -> (Buffer.t, _) result
+
+val pretty_print_expression : CST.expr -> (Buffer.t, _) result

src/passes/01-parsing/cameligo/Parser.mly

@@ -93,7 +93,7 @@ tuple(item):
 
 list__(item):
   "[" sep_or_term_list(item,";")? "]" {
-    let compound = Brackets ($1,$3)
+    let compound = Some (Brackets ($1,$3))
     and region = cover $1 $3 in
     let elements, terminator =
       match $2 with
@@ -194,7 +194,7 @@ record_type:
     let () = Utils.nsepseq_to_list ne_elements
              |> Scoping.check_fields in
     let region = cover $1 $3
-    and value  = {compound = Braces ($1,$3); ne_elements; terminator}
+    and value  = {compound = Some (Braces ($1,$3)); ne_elements; terminator}
     in TRecord {region; value} }
 
 field_decl:
@@ -300,7 +300,7 @@ record_pattern:
   "{" sep_or_term_list(field_pattern,";") "}" {
     let ne_elements, terminator = $2 in
     let region = cover $1 $3 in
-    let value  = {compound = Braces ($1,$3); ne_elements; terminator}
+    let value  = {compound = Some (Braces ($1,$3)); ne_elements; terminator}
     in {region; value} }
 
 field_pattern:
@@ -377,22 +377,18 @@ if_then_else(right_expr):
                   test     = $2;
                   kwd_then = $3;
                   ifso     = $4;
-                  kwd_else = $5;
+                  ifnot    = Some($5,$6)}
-                  ifnot    = $6}
     in ECond {region; value} }
 
 if_then(right_expr):
   "if" expr "then" right_expr {
-    let the_unit = ghost, ghost in
-    let ifnot    = EUnit (wrap_ghost the_unit) in
     let stop     = expr_to_region $4 in
     let region   = cover $1 stop in
     let value    = {kwd_if   = $1;
                     test     = $2;
                     kwd_then = $3;
                     ifso     = $4;
-                    kwd_else = ghost;
+                    ifnot    = None}
-                    ifnot}
     in ECond {region; value} }
 
 base_if_then_else__open(x):
@@ -630,7 +626,7 @@ record_expr:
   "{" sep_or_term_list(field_assignment,";") "}" {
     let ne_elements, terminator = $2 in
     let region = cover $1 $3 in
-    let value  = {compound = Braces ($1,$3);
+    let value  = {compound = Some (Braces ($1,$3));
                   ne_elements;
                   terminator}
     in {region; value} }
@@ -643,7 +639,7 @@ update_record:
       lbrace   = $1;
       record   = $2;
       kwd_with = $3;
-      updates  = {value = {compound = Braces (ghost, ghost);
+      updates  = {value = {compound = None;
                            ne_elements;
                            terminator};
                   region = cover $3 $5};
@@ -671,7 +667,7 @@ path :
 sequence:
   "begin" series? "end" {
     let region   = cover $1 $3
-    and compound = BeginEnd ($1,$3) in
+    and compound = Some (BeginEnd ($1,$3)) in
     let elements = $2 in
     let value    = {compound; elements; terminator=None}
     in {region; value} }
@@ -691,7 +687,7 @@ let_in_sequence:
     let seq       = $6 in
     let stop      = nsepseq_to_region expr_to_region seq in
     let region    = cover $1 stop in
-    let compound  = BeginEnd (Region.ghost, Region.ghost) in
+    let compound  = None in
     let elements  = Some seq in
     let value     = {compound; elements; terminator=None} in
     let body      = ESeq {region; value} in

src/passes/01-parsing/cameligo/Pretty.ml

@@ -173,13 +173,15 @@ and pp_clause {value; _} =
     pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs)
 
 and pp_cond_expr {value; _} =
-  let {test; ifso; kwd_else; ifnot; _} = value in
+  let {test; ifso; ifnot; _} = value in
   let test = string "if " ^^ group (nest 3 (pp_expr test))
   and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
-  and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
+  in match ifnot with
-  in if   kwd_else#is_ghost
+    Some (_,ifnot) ->
-     then test ^/^ ifso
+    let ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) in
-     else test ^/^ ifso ^/^ ifnot
+    test ^/^ ifso ^/^ ifnot
+  | None ->
+    test ^/^ ifso
 
 and pp_annot_expr {value; _} =
   let expr, _, type_expr = value.inside in
@@ -243,18 +245,15 @@ and pp_injection :
     let sep = string ";" ^^ break 1 in
     let elements = Utils.sepseq_to_list elements in
     let elements = separate_map sep printer elements in
-    match pp_compound compound with
+    match Option.map pp_compound compound with
       None -> elements
     | Some (opening, closing) ->
         string opening ^^ nest 1 elements ^^ string closing
 
 and pp_compound = function
-  BeginEnd (start, _) ->
+  BeginEnd (_, _) -> ("begin","end")
-    if start#is_ghost then None else Some ("begin","end")
+| Braces (_, _)   -> ("{","}")
-| Braces (start, _) ->
+| Brackets (_, _) -> ("[","]")
-    if start#is_ghost then None else Some ("{","}")
-| Brackets (start, _) ->
-    if start#is_ghost then None else Some ("[","]")
 
 and pp_constr_expr = function
   ENone      _ -> string "None"
@@ -282,7 +281,7 @@ and pp_ne_injection :
   fun printer {value; _} ->
     let {compound; ne_elements; _} = value in
     let elements = pp_nsepseq ";" printer ne_elements in
-    match pp_compound compound with
+    match Option.map pp_compound compound with
       None -> elements
     | Some (opening, closing) ->
         string opening ^^ nest 1 elements ^^ string closing
@@ -356,8 +355,8 @@ and pp_let_in {value; _} =
     | Some _ -> "let rec " in
   let binding = pp_let_binding binding
   and attr    = pp_attributes attributes
-  in string let_str ^^ binding ^^ attr
+  in string let_str ^^ binding ^^ attr ^^ string " in"
-     ^^ hardline ^^ group (string "in " ^^ nest 3 (pp_expr body))
+     ^^ hardline ^^ group (pp_expr body)
 
 and pp_fun {value; _} =
   let {binders; lhs_type; body; _} = value in
@@ -375,7 +374,7 @@ and pp_seq {value; _} =
   let sep = string ";" ^^ hardline in
   let elements = Utils.sepseq_to_list elements in
   let elements = separate_map sep pp_expr elements in
-  match pp_compound compound with
+  match Option.map pp_compound compound with
     None -> elements
   | Some (opening, closing) ->
      string opening
@@ -406,7 +405,7 @@ and pp_variants {value; _} =
   let head = pp_variant head in
   let head = if tail = [] then head else ifflat head (blank 2 ^^ head) in
   let rest = List.map snd tail in
-  let app variant = break 1 ^^ string "| " ^^ pp_variant variant
+  let app variant = group (break 1 ^^ string "| " ^^ pp_variant variant)
   in head ^^ concat_map app rest
 
 and pp_variant {value; _} =

src/passes/01-parsing/pascaligo.ml

@@ -5,6 +5,7 @@ module Scoping  = Parser_pascaligo.Scoping
 module Region   = Simple_utils.Region
 module ParErr   = Parser_pascaligo.ParErr
 module SSet     = Set.Make (String)
+module Pretty   = Parser_pascaligo.Pretty
 
 (* Mock IOs TODO: Fill them with CLI options *)
 
@@ -153,3 +154,23 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
 (* Preprocessing a contract in a file *)
 
 let preprocess source = apply (fun () -> Unit.preprocess source)
+
+let pretty_print cst =
+  let doc    = Pretty.print cst in
+  let buffer = Buffer.create 131 in
+  let width  =
+    match Terminal_size.get_columns () with
+      None -> 60
+    | Some c -> c in
+  let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
+  in Trace.ok buffer
+
+let pretty_print_expression cst =
+  let doc    = Pretty.pp_expr cst in
+  let buffer = Buffer.create 131 in
+  let width  =
+    match Terminal_size.get_columns () with
+      None -> 60
+    | Some c -> c in
+  let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
+  in Trace.ok buffer

src/passes/01-parsing/pascaligo.mli

@@ -21,3 +21,8 @@ val parse_expression : string -> (CST.expr, parser_error) result
 
 (** Preprocess a given PascaLIGO file and preprocess it. *)
 val preprocess : string -> (Buffer.t, parser_error) result
+
+(** Take a PascaLIGO cst and pretty_print it *)
+val pretty_print : CST.t -> (Buffer.t, _) result
+
+val pretty_print_expression : CST.expr -> (Buffer.t, _) result

src/passes/01-parsing/pascaligo/Parser.mly

@@ -255,23 +255,6 @@ fun_expr:
 
 open_fun_decl:
   ioption ("recursive") "function" fun_name parameters type_expr_colon? "is"
-  block "with" expr {
-    Scoping.check_reserved_name $3;
-    let stop   = expr_to_region $9 in
-    let region = cover $2 stop
-    and value  = {kwd_recursive= $1;
-                  kwd_function = $2;
-                  fun_name     = $3;
-                  param        = $4;
-                  ret_type     = $5;
-                  kwd_is       = $6;
-                  block_with   = Some ($7, $8);
-                  return       = $9;
-                  terminator   = None;
-                  attributes   = None}
-    in {region; value}
-  }
-| ioption ("recursive") "function" fun_name parameters type_expr_colon? "is"
   expr {
     Scoping.check_reserved_name $3;
     let stop   = expr_to_region $7 in
@@ -282,11 +265,11 @@ open_fun_decl:
                   param        = $4;
                   ret_type     = $5;
                   kwd_is       = $6;
-                  block_with   = None;
                   return       = $7;
                   terminator   = None;
                   attributes   = None}
-    in {region; value} }
+    in {region; value}
+  }
 
 fun_decl:
   open_fun_decl ";"? {
@@ -588,7 +571,7 @@ case_clause(rhs):
 
 assignment:
   lhs ":=" rhs {
-    let stop   = rhs_to_region $3 in
+    let stop   = expr_to_region $3 in
     let region = cover (lhs_to_region $1) stop
     and value  = {lhs = $1; assign = $2; rhs = $3}
     in {region; value} }
@@ -665,6 +648,20 @@ expr:
 | cond_expr  { $1                        }
 | disj_expr  { $1                        }
 | fun_expr   { EFun $1                   }
+| block_with { EBlock $1                 }
+
+block_with :
+  block "with" expr {
+    let start = $2
+    and stop  = expr_to_region $3 in
+    let region = cover start stop in
+    let value : CST.block_with = {
+      block    = $1;
+      kwd_with = $2;
+      expr     = $3;
+    }
+    in {value;region}
+  }
 
 cond_expr:
   "if" expr "then" expr ";"? "else" expr {

src/passes/01-parsing/pascaligo/Pretty.ml

@@ -81,7 +81,7 @@ and pp_variants {value; _} =
   let head = if tail = [] then head
              else ifflat head (string "  " ^^ head) in
   let rest = List.map snd tail in
-  let app variant = break 1 ^^ string "| " ^^ pp_variant variant
+  let app variant = group (break 1 ^^ string "| " ^^ pp_variant variant)
   in head ^^ concat_map app rest
 
 and pp_variant {value; _} =
@@ -136,7 +136,7 @@ and pp_fun_expr {value; _} =
 
 and pp_fun_decl {value; _} =
   let {kwd_recursive; fun_name; param;
-       ret_type; block_with; return; attributes; _} = value in
+       ret_type; return; attributes; _} = value in
   let start =
     match kwd_recursive with
         None -> string "function"
@@ -145,10 +145,9 @@ and pp_fun_decl {value; _} =
   let parameters = pp_par pp_parameters param in
   let expr = pp_expr return in
   let body =
-    match block_with with
+    match return with
-            None -> group (nest 2 (break 1 ^^ expr))
+      EBlock _ -> group (break 1 ^^ expr)
-    | Some (b,_) -> hardline ^^ pp_block b ^^ string " with"
+    | _ -> group (nest 2 (break 1 ^^ expr))
-                   ^^ group (nest 4 (break 1 ^^ expr))
   and attr =
     match attributes with
         None -> empty
@@ -379,6 +378,14 @@ and pp_expr = function
 | EPar        e -> pp_par pp_expr e
 | EFun        e -> pp_fun_expr e
 | ECodeInj    e -> pp_code_inj e
+| EBlock      e -> pp_block_with e
+
+and pp_block_with {value; _} =
+  let {block;kwd_with; expr;_} = value in
+  let expr = value.expr in
+  let expr = pp_expr expr in
+  group(pp_block block ^^ string " with"
+    ^^ group (nest 4 (break 1 ^^ expr)))
 
 and pp_annot_expr {value; _} =
   let expr, _, type_expr = value.inside in

src/passes/01-parsing/pascaligo/error.messages.checked-in

@@ -4147,30 +4147,6 @@ contract: Function With
 
 <YOUR SYNTAX ERROR MESSAGE HERE>
 
-contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is Begin Skip End While
-##
-## Ends in an error in state: 582.
-##
-## open_fun_decl -> Recursive Function Ident parameters COLON type_expr Is block . With expr [ Type SEMI Recursive RBRACE Function End EOF Const Attributes ]
-##
-## The known suffix of the stack is as follows:
-## Recursive Function Ident parameters COLON type_expr Is block
-##
-
-<YOUR SYNTAX ERROR MESSAGE HERE>
-
-contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is Begin Skip End With With
-##
-## Ends in an error in state: 583.
-##
-## open_fun_decl -> Recursive Function Ident parameters COLON type_expr Is block With . expr [ Type SEMI Recursive RBRACE Function End EOF Const Attributes ]
-##
-## The known suffix of the stack is as follows:
-## Recursive Function Ident parameters COLON type_expr Is block With
-##
-
-<YOUR SYNTAX ERROR MESSAGE HERE>
-
 contract: Recursive Function Ident LPAR Const Ident COLON Ident RPAR COLON String Is With
 ##
 ## Ends in an error in state: 89.

src/passes/01-parsing/reasonligo.ml

@@ -146,12 +146,25 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
 let preprocess source = apply (fun () -> Unit.preprocess source)
 
 (* Pretty-print a file (after parsing it). *)
-
+let pretty_print cst =
-let pretty_print source =
+  let doc    = Pretty.print cst in
-  match parse_file source with
+  let buffer = Buffer.create 131 in
-    Stdlib.Error _ as e -> e
+  let width  =
-  | Ok ast ->
+    match Terminal_size.get_columns () with
-      let doc    = Pretty.print (fst ast) in
+      None -> 60
+    | Some c -> c in
+  let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
+  in Trace.ok buffer
+
+let pretty_print_from_source source =
+  match parse_file source with
+    Stdlib.Error _ as e -> e
+  | Ok cst ->
+    pretty_print @@ fst cst
+
+
+let pretty_print_expression cst =
+  let doc    = Pretty.pp_expr cst in
   let buffer = Buffer.create 131 in
   let width  =
     match Terminal_size.get_columns () with

src/passes/01-parsing/reasonligo.mli

@@ -21,5 +21,10 @@ val parse_expression : string -> (CST.expr , Errors.parser_error) result
 (** Preprocess a given ReasonLIGO file and preprocess it. *)
 val preprocess : string -> (Buffer.t , Errors.parser_error) result
 
-(** Pretty-print a given CameLIGO file (after parsing it). *)
+(** Pretty-print a given ReasonLIGO file (after parsing it). *)
-val pretty_print : string -> (Buffer.t , Errors.parser_error) result
+val pretty_print_from_source : string -> (Buffer.t , Errors.parser_error) result
+
+(** Take a ReasonLIGO cst and pretty_print it *)
+val pretty_print : CST.t -> (Buffer.t, _) result
+
+val pretty_print_expression : CST.expr -> (Buffer.t, _) result

src/passes/01-parsing/reasonligo/Parser.mly

@@ -131,7 +131,7 @@ tuple(item):
 
 list__(item):
   "[" sep_or_term_list(item,";")? "]" {
-    let compound = Brackets ($1,$3)
+    let compound = Some (Brackets ($1,$3))
     and region = cover $1 $3 in
     let elements, terminator =
       match $2 with
@@ -224,7 +224,7 @@ record_type:
     let () = Utils.nsepseq_to_list ne_elements
              |> Scoping.check_fields in
     let region = cover $1 $3
-    and value  = {compound = Braces ($1,$3); ne_elements; terminator}
+    and value  = {compound = Some(Braces ($1,$3)); ne_elements; terminator}
     in TRecord {region; value} }
 
 type_expr_field:
@@ -362,7 +362,7 @@ record_pattern:
   "{" sep_or_term_list(field_pattern,",") "}" {
     let ne_elements, terminator = $2 in
     let region = cover $1 $3 in
-    let value  = {compound = Braces ($1,$3);
+    let value  = {compound = Some (Braces ($1,$3));
                   ne_elements;
                   terminator}
     in {region; value} }
@@ -592,15 +592,12 @@ parenthesized_expr:
 
 if_then(right_expr):
   "if" parenthesized_expr "{" closed_if ";"? "}" {
-    let the_unit = ghost, ghost in
-    let ifnot    = EUnit {region=ghost; value=the_unit} in
     let region   = cover $1 $6 in
     let value    = {kwd_if   = $1;
                     test     = $2;
                     kwd_then = $3;
                     ifso     = $4;
-                    kwd_else = ghost;
+                    ifnot    = None}
-                    ifnot}
     in ECond {region; value} }
 
 if_then_else(right_expr):
@@ -611,8 +608,7 @@ if_then_else(right_expr):
                   test     = $2;
                   kwd_then = $3;
                   ifso     = $4;
-                  kwd_else = $6;
+                  ifnot    = Some ($6,$9)}
-                  ifnot    = $9}
     in ECond {region; value} }
 
 base_if_then_else__open(x):
@@ -825,7 +821,7 @@ list_or_spread:
     let elts, terminator = $4 in
     let elts = Utils.nsepseq_cons $2 $3 elts in
     let value = {
-      compound = Brackets ($1,$5);
+      compound = Some (Brackets ($1,$5));
       elements = Some elts;
       terminator}
     and region = cover $1 $5 in
@@ -837,7 +833,7 @@ list_or_spread:
     in EList (ECons {region; value})
   }
 | "[" expr? "]" {
-    let compound = Brackets ($1,$3)
+    let compound = Some (Brackets ($1,$3))
     and elements =
       match $2 with
         None -> None
@@ -913,7 +909,7 @@ update_record:
       lbrace   = $1;
       record   = $3;
       kwd_with = $4;
-      updates  = {value = {compound = Braces (ghost, ghost);
+      updates  = {value = {compound = None;
                            ne_elements;
                            terminator};
                   region = cover $4 $6};
@@ -949,7 +945,7 @@ exprs:
       in
       let sequence = ESeq {
         value = {
-          compound   = BeginEnd (ghost, ghost);
+          compound   = None; 
           elements   = Some val_;
           terminator = snd c};
         region = sequence_region
@@ -982,7 +978,7 @@ more_field_assignments:
 sequence:
   "{" exprs "}" {
     let elts, _region = $2 in
-    let compound = Braces ($1, $3) in
+    let compound = Some (Braces ($1, $3)) in
     let value    = {compound;
                     elements = Some elts;
                     terminator = None} in
@@ -991,7 +987,7 @@ sequence:
 
 record:
   "{" field_assignment more_field_assignments? "}" {
-    let compound = Braces ($1,$4) in
+    let compound = Some (Braces ($1,$4)) in
     let region   = cover $1 $4 in
 
     match $3 with
@@ -1010,7 +1006,7 @@ record:
     let field_name = {$2 with value} in
     let comma, elts = $3 in
     let ne_elements = Utils.nsepseq_cons field_name comma elts in
-    let compound = Braces ($1,$4) in
+    let compound = Some (Braces ($1,$4)) in
     let region   = cover $1 $4 in
     {value = {compound; ne_elements; terminator = None}; region} }
 

src/passes/01-parsing/reasonligo/Pretty.ml

@@ -179,13 +179,13 @@ and pp_clause {value; _} =
   prefix 4 1 (pp_pattern pattern ^^ string " =>") (pp_expr rhs)
 
 and pp_cond_expr {value; _} =
-  let {test; ifso; kwd_else; ifnot; _} = value in
+  let {test; ifso; ifnot; _} = value in
   let if_then =
     string "if" ^^ string " (" ^^ pp_expr test ^^ string ")" ^^ string " {" ^^ break 0
     ^^ group (nest 2 (break 2 ^^ pp_expr ifso)) ^^ hardline ^^ string "}" in
-  if kwd_else#is_ghost then
+  match ifnot with
-    if_then
+    None -> if_then
-  else
+  | Some (_,ifnot) ->
     if_then
     ^^ string " else" ^^ string " {" ^^ break 0 ^^ group (nest 2 (break 2 ^^ pp_expr ifnot)) ^^ hardline ^^ string "}"
 
@@ -252,18 +252,15 @@ and pp_injection :
     let sep = (string ",") ^^ break 1 in
     let elements = Utils.sepseq_to_list elements in
     let elements = separate_map sep printer elements in
-    match pp_compound compound with
+    match Option.map pp_compound compound with
       None -> elements
     | Some (opening, closing) ->
         string opening ^^ nest 1 elements ^^ string closing
 
 and pp_compound = function
-  BeginEnd (start, _) ->
+  BeginEnd (_, _) -> ("begin","end")
-    if start#is_ghost then None else Some ("begin","end")
+| Braces   (_, _) -> ("{","}")
-| Braces (start, _) ->
+| Brackets (_, _) -> ("[","]")
-    if start#is_ghost then None else Some ("{","}")
-| Brackets (start, _) ->
-    if start#is_ghost then None else Some ("[","]")
 
 and pp_constr_expr = function
   ENone      _ -> string "None"
@@ -291,7 +288,7 @@ and pp_ne_injection :
   fun printer {value; _} ->
     let {compound; ne_elements; _} = value in
     let elements = pp_nsepseq "," printer ne_elements in
-    match pp_compound compound with
+    match Option.map pp_compound compound with
       None -> elements
     | Some (opening, closing) ->
         string opening ^^ nest 2 (break 0 ^^ elements) ^^ break 1 ^^ string closing
@@ -387,7 +384,7 @@ and pp_seq {value; _} =
   let sep = string ";" ^^ hardline in
   let elements = Utils.sepseq_to_list elements in
   let elements = separate_map sep pp_expr elements in
-  match pp_compound compound with
+  match Option.map pp_compound compound with
     None -> elements
   | Some (opening, closing) ->
      string opening

src/passes/03-tree_abstraction/cameligo/cameligo.ml

@@ -2,7 +2,11 @@ module CST = Cst.Cameligo
 module AST = Ast_imperative
 
 module Compiler   = Compiler
+module Decompiler = Decompiler
 module Errors = Errors
 
 let compile_program    = Compiler.compile_program
 let compile_expression = Compiler.compile_expression
+
+let decompile_program    = Decompiler.decompile_program
+let decompile_expression = Decompiler.decompile_expression

src/passes/03-tree_abstraction/cameligo/cameligo.mli

@@ -8,5 +8,7 @@ module Errors = Errors
 
 
 val compile_expression : CST.expr -> (AST.expr, Errors.abs_error) result
-
 val compile_program : CST.ast -> (AST.program, Errors.abs_error) result
+
+val decompile_expression : AST.expr -> (CST.expr, _) result
+val decompile_program    : AST.program -> (CST.ast, _) result

src/passes/03-tree_abstraction/cameligo/compiler.ml

@@ -11,6 +11,7 @@ module Option = Simple_utils.Option
 
 open Combinators
 
+let (<@) f g x = f (g x)
 let nseq_to_list (hd, tl) = hd :: tl
 let npseq_to_list (hd, tl) = hd :: (List.map snd tl)
 let npseq_to_nelist (hd, tl) = hd, (List.map snd tl)
@@ -247,7 +248,7 @@ in trace (abstracting_expr_tracer t) @@
       let%bind ty_opt =
         bind_map_option (fun (re,te) -> let%bind te = compile_type_expression te in ok(Location.lift re,te)) lhs_type in
       let%bind rhs = compile_expression let_rhs in
-      let rhs_b = Var.fresh ~name: "rhs" () in
+      let rhs_b = Var.fresh ~name:"rhs" () in
       let rhs',rhs_b_expr =
         match ty_opt with
           None -> rhs, e_variable ~loc rhs_b
@@ -491,7 +492,8 @@ in trace (abstracting_expr_tracer t) @@
       let (c , loc) = r_split c in
       let%bind expr = compile_expression c.test in
       let%bind match_true = compile_expression c.ifso in
-      let%bind match_false = compile_expression c.ifnot in
+      let%bind match_false = bind_map_option (compile_expression <@ snd) c.ifnot in
+      let match_false = Option.unopt ~default:(e_unit ()) match_false in
       return @@ e_cond ~loc expr match_true match_false
   | ECodeInj ci ->
      let ci, loc   = r_split ci in
@@ -541,7 +543,7 @@ and compile_fun lamb' : (expr , abs_error) result =
     let aux ((var : Raw.variable) , ty_opt) =
       match var.value , ty_opt with
       | "storage" , None ->
-        ok (var , t_variable ~loc @@ Var.fresh ~name:"storage" ())
+        ok (var , t_variable_ez ~loc "storage")
       | _ , None ->
           fail @@ untyped_fun_param var
       | _ , Some ty -> (

src/passes/03-tree_abstraction/cameligo/decompiler.ml

@@ -0,0 +1,504 @@
+module AST = Ast_imperative
+module CST = Cst.Cameligo
+module Predefined = Predefined.Tree_abstraction.Cameligo
+
+open Trace
+
+(* General tools *)
+let (<@) f g x = f (g x)
+
+(* Utils *)
+let rg = Region.ghost
+let wrap : type a. a -> a CST.reg = fun value -> {value;region=rg}
+let list_to_sepseq lst =
+  match lst with
+    [] -> None
+  |  hd :: lst -> 
+      let aux e = (rg, e) in
+      Some (hd, List.map aux lst)
+let list_to_nsepseq lst = 
+  match list_to_sepseq lst with
+    Some s -> ok @@ s
+  | None   -> failwith "List is empty"
+    
+let nelist_to_npseq (hd, lst) = (hd, List.map (fun e -> (rg, e)) lst)
+let npseq_cons hd lst = hd,(rg, fst lst)::(snd lst)
+
+let par a = CST.{lpar=rg;inside=a;rpar=rg}
+let inject compound a = CST.{compound;elements=a;terminator=Some(rg)}
+let ne_inject compound a = CST.{compound;ne_elements=a;terminator=Some(rg)}
+let prefix_colon a = (rg, a)
+let braces = Some (CST.Braces (rg,rg))
+let brackets = Some (CST.Brackets (rg,rg))
+let beginEnd = Some (CST.BeginEnd (rg,rg))
+
+(* Decompiler *)
+
+let decompile_variable : type a. a Var.t -> CST.variable = fun var ->
+  let var = Format.asprintf "%a" Var.pp var in
+  if String.contains var '#' then
+    let var = String.split_on_char '#' var in
+    wrap @@ "gen__" ^ (String.concat "" var)
+  else 
+    if String.length var > 4 && String.equal "gen__" @@ String.sub var 0 5 then
+      wrap @@ "user__" ^ var
+    else
+      wrap @@ var
+
+let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
+  let return te = ok @@ te in
+  match te.type_content with
+    T_sum sum ->
+    let sum = AST.CMap.to_kv_list sum in
+    let aux (AST.Constructor c, AST.{ctor_type;_}) =
+      let constr = wrap c in 
+      let%bind arg = decompile_type_expr ctor_type in
+      let arg = Some (rg, arg) in
+      let variant : CST.variant = {constr;arg} in
+      ok @@ wrap variant 
+    in
+    let%bind sum = bind_map_list aux sum in
+    let%bind sum = list_to_nsepseq sum in
+    return @@ CST.TSum (wrap sum)
+  | T_record record -> 
+    let record = AST.LMap.to_kv_list record in
+    let aux (AST.Label c, AST.{field_type;_}) =
+      let field_name = wrap c in 
+      let colon = rg in
+      let%bind field_type = decompile_type_expr field_type in
+      let variant : CST.field_decl = {field_name;colon;field_type} in
+      ok @@ wrap variant 
+    in
+    let%bind record = bind_map_list aux record in
+    let%bind record = list_to_nsepseq record in
+    return @@ CST.TRecord (wrap @@ ne_inject (braces) record)
+  | T_tuple tuple ->
+    let%bind tuple = bind_map_list decompile_type_expr tuple in
+    let%bind tuple = list_to_nsepseq @@ tuple in
+    return @@ CST.TProd (wrap tuple)
+  | T_arrow {type1;type2} ->
+    let%bind type1 = decompile_type_expr type1 in
+    let%bind type2 = decompile_type_expr type2 in
+    let arrow = (type1, rg, type2) in
+    return @@ CST.TFun (wrap arrow)
+  | T_variable var ->
+    let var = decompile_variable var in
+    return @@ CST.TVar (var)
+  | T_constant const ->
+    let const = Predefined.type_constant_to_string const in
+    return @@ CST.TVar (wrap const)
+  | T_operator (operator, lst) ->
+    let operator = wrap @@ Predefined.type_operator_to_string operator in
+    let%bind lst = bind_map_list decompile_type_expr lst in
+    let%bind lst = list_to_nsepseq lst in
+    let lst : _ CST.par = {lpar=rg;inside=lst;rpar=rg} in
+    return @@ CST.TApp (wrap (operator,wrap lst))
+  | T_annoted _annot ->
+    failwith "let's work on it later"
+
+let get_e_variable : AST.expression -> _ result = fun expr ->
+  match expr.expression_content with 
+    E_variable var -> ok @@ var
+  | _ -> failwith @@ 
+    Format.asprintf "%a should be a variable expression"
+    AST.PP.expression expr
+
+let get_e_tuple : AST.expression -> _ result = fun expr ->
+  match expr.expression_content with 
+    E_tuple tuple -> ok @@ tuple
+  | E_variable _
+  | E_literal _
+  | E_constant _
+  | E_lambda _ -> ok @@ [expr]
+  | _ -> failwith @@ 
+    Format.asprintf "%a should be a tuple expression"
+    AST.PP.expression expr
+
+let pattern_type var ty_opt =
+  let var = CST.PVar (decompile_variable var) in
+  match ty_opt with
+    Some s -> 
+      let%bind type_expr = decompile_type_expr s in
+      ok @@ CST.PTyped (wrap @@ CST.{pattern=var;colon=rg;type_expr})
+  | None -> ok @@ var
+
+let rec decompile_expression : AST.expression -> _ result = fun expr ->
+  let return_expr expr = ok @@ expr in
+  let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in
+  match expr.expression_content with
+    E_variable name -> 
+    let var = decompile_variable name in
+    return_expr @@ CST.EVar (var)
+  | E_constant {cons_name; arguments} ->
+    let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in
+    (match arguments with
+      [] -> return_expr @@ expr
+    | _ ->
+      let%bind arguments = map List.Ne.of_list @@
+        map (List.map (fun x -> CST.EPar (wrap @@ par @@ x))) @@
+        bind_map_list decompile_expression arguments in
+      let const = wrap (expr, arguments) in
+      return_expr_with_par @@ CST.ECall const
+    )
+  | E_literal literal ->
+    (match literal with
+        Literal_unit  ->  return_expr @@ CST.EUnit (wrap (rg,rg))
+      | Literal_int i ->  return_expr @@ CST.EArith (Int (wrap ("",i)))
+      | Literal_nat n ->  return_expr @@ CST.EArith (Nat (wrap ("",n)))
+      | Literal_timestamp time -> 
+        let time = Tezos_utils.Time.Protocol.to_notation @@
+          Tezos_utils.Time.Protocol.of_seconds @@ Z.to_int64 time in
+          (* TODO combinators for CSTs. *)
+        let%bind ty = decompile_type_expr @@ AST.t_timestamp () in
+        let time = CST.EString (String (wrap time)) in
+        return_expr @@ CST.EAnnot (wrap @@ par (time, rg, ty))
+      | Literal_mutez mtez -> return_expr @@ CST.EArith (Mutez (wrap ("",mtez)))
+      | Literal_string (Standard str) -> return_expr @@ CST.EString (String   (wrap str))
+      | Literal_string (Verbatim ver) -> return_expr @@ CST.EString (Verbatim (wrap ver))
+      | Literal_bytes b ->
+        let b = Hex.of_bytes b in
+        let s = Hex.to_string b in
+        return_expr @@ CST.EBytes (wrap (s,b))
+      | Literal_address addr ->
+        let addr = CST.EString (String (wrap addr)) in
+        let%bind ty = decompile_type_expr @@ AST.t_address () in
+        return_expr @@ CST.EAnnot (wrap @@ par (addr,rg,ty))
+      | Literal_signature sign ->
+        let sign = CST.EString (String (wrap sign)) in
+        let%bind ty = decompile_type_expr @@ AST.t_signature () in
+        return_expr @@ CST.EAnnot (wrap @@ par (sign,rg,ty))
+      | Literal_key k ->
+        let k = CST.EString (String (wrap k)) in
+        let%bind ty = decompile_type_expr @@ AST.t_key () in
+        return_expr @@ CST.EAnnot (wrap @@ par (k,rg,ty))
+      | Literal_key_hash kh ->
+        let kh = CST.EString (String (wrap kh)) in
+        let%bind ty = decompile_type_expr @@ AST.t_key_hash () in
+        return_expr @@ CST.EAnnot (wrap @@ par (kh,rg,ty))
+      | Literal_chain_id _ 
+      | Literal_void
+      | Literal_operation _ ->
+        failwith "chain_id, void, operation are not created currently ?"
+    )
+  | E_application {lamb;args} ->
+    let%bind lamb = decompile_expression lamb in
+    let%bind args = map List.Ne.of_list @@ 
+      bind (bind_map_list decompile_expression) @@ 
+      get_e_tuple args
+    in
+    return_expr @@ CST.ECall (wrap (lamb,args))
+  | E_lambda lambda ->
+    let%bind (binders,_lhs_type,_block_with,body) = decompile_lambda lambda in
+    let fun_expr : CST.fun_expr = {kwd_fun=rg;binders;lhs_type=None;arrow=rg;body} in
+    return_expr_with_par @@ CST.EFun (wrap @@ fun_expr)
+  | E_recursive _ ->
+    failwith "corner case : annonymous recursive function"
+  | E_let_in {let_binder;rhs;let_result;inline} ->
+    let var = CST.PVar (decompile_variable @@ fst let_binder) in
+    let binders = (var,[]) in
+    let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) @@ snd let_binder in
+    let%bind let_rhs = decompile_expression rhs in
+    let binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
+    let%bind body = decompile_expression let_result in
+    let attributes = decompile_attributes inline in
+    let lin : CST.let_in = {kwd_let=rg;kwd_rec=None;binding;kwd_in=rg;body;attributes} in
+    return_expr @@ CST.ELetIn (wrap lin)
+  | E_raw_code {language; code} ->
+    let language = wrap @@ wrap @@ language in
+    let%bind code = decompile_expression code in
+    let ci : CST.code_inj = {language;code;rbracket=rg} in
+    return_expr @@ CST.ECodeInj (wrap ci)
+  | E_constructor {constructor;element} ->
+    let Constructor constr = constructor in
+    let constr = wrap constr in
+    let%bind element = decompile_expression element in
+    return_expr_with_par @@ CST.EConstr (EConstrApp (wrap (constr, Some element)))
+  | E_matching {matchee; cases} ->
+    let%bind expr  = decompile_expression matchee in
+    let%bind cases = decompile_matching_cases cases in
+    let cases : _ CST.case = {kwd_match=rg;expr;kwd_with=rg;lead_vbar=None;cases} in
+    return_expr @@ CST.ECase (wrap cases)
+  | E_record record  ->
+    let record = AST.LMap.to_kv_list record in
+    let aux (AST.Label str, expr) = 
+      let field_name = wrap str in
+      let%bind field_expr = decompile_expression expr in
+      let field : CST.field_assign = {field_name;assignment=rg;field_expr} in
+      ok @@ wrap field
+    in
+    let%bind record = bind_map_list aux record in
+    let%bind record = list_to_nsepseq record in
+    let record = ne_inject braces record in
+    (* why is the record not empty ? *)
+    return_expr @@ CST.ERecord (wrap record)
+  | E_accessor {record; path} ->
+    (match List.rev path with
+      Access_map e :: [] ->
+      let%bind map = decompile_expression record in
+      let%bind e = decompile_expression e in
+      let arg = e,[map] in
+      return_expr @@ CST.ECall( wrap (CST.EVar (wrap "Map.find_opt"), arg))
+    | Access_map e :: lst ->
+      let path = List.rev lst in
+      let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
+      let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
+      let proj : CST.projection = {struct_name;selector=rg;field_path} in
+      let%bind e = decompile_expression e in
+      let arg = e,[CST.EProj (wrap proj)] in
+      return_expr @@ CST.ECall( wrap (CST.EVar (wrap "Map.find_opt"), arg))
+    | _ ->
+      let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
+       let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
+      let proj : CST.projection = {struct_name;selector=rg;field_path} in
+      return_expr @@ CST.EProj (wrap proj)
+    )
+  (* Update on multiple field of the same record. may be removed by adding sugar *)
+  | E_update {record={expression_content=E_update _;_} as record;path;update} ->
+    let%bind record = decompile_expression record in
+    let%bind (record,updates) = match record with
+      CST.EUpdate {value;_} -> ok @@ (value.record,value.updates) 
+    | _ -> failwith @@ Format.asprintf "Inpossible case %a" AST.PP.expression expr 
+    in
+    let%bind var,path = match path with 
+      Access_record var::path -> ok @@ (var,path)
+    | _ -> failwith "Impossible case %a"
+    in
+    let%bind field_path = decompile_to_path (Var.of_name var) path in
+    let%bind field_expr = decompile_expression update in
+    let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+    let updates = updates.value.ne_elements in
+    let updates = wrap @@ ne_inject braces @@ npseq_cons (wrap @@ field_assign) updates in
+    let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
+    return_expr @@ CST.EUpdate (wrap @@ update)
+  | E_update {record; path; update} ->
+    let%bind record = map (decompile_variable) @@ get_e_variable record in
+    let%bind field_expr = decompile_expression update in
+    let (struct_name,field_path) = List.Ne.of_list path in
+    (match field_path with
+      [] -> 
+      (match struct_name with
+        Access_record name ->
+        let record : CST.path = Name record in
+        let field_path = CST.Name (wrap name) in
+        let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+        let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in
+        let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
+        return_expr @@ CST.EUpdate (wrap update)
+      | Access_tuple i ->
+        let record : CST.path = Name record in
+        let field_path = CST.Name (wrap @@ Z.to_string i) in
+        let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+        let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in
+        let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
+        return_expr @@ CST.EUpdate (wrap update)
+      | Access_map e ->
+        let%bind e = decompile_expression e in
+        let arg = field_expr,[e; CST.EVar record] in
+        return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"), arg))
+      )
+    | _ ->
+      let%bind struct_name = match struct_name with
+          Access_record name -> ok @@ wrap name
+        | Access_tuple i -> ok @@ wrap @@ Z.to_string i 
+        | Access_map _ -> failwith @@ Format.asprintf "invalid map update %a" AST.PP.expression expr
+      in
+      (match List.rev field_path with
+        Access_map e :: lst ->
+        let field_path = List.rev lst in
+        let%bind field_path = bind_map_list decompile_to_selection field_path in
+        let%bind field_path = list_to_nsepseq field_path in
+        let field_path : CST.projection = {struct_name; selector=rg;field_path} in
+        let field_path = CST.EProj (wrap @@ field_path) in
+        let%bind e = decompile_expression e in
+        let arg = field_expr, [e; field_path] in
+        return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"),arg))
+      | _ ->
+        let%bind field_path = bind_map_list decompile_to_selection field_path in
+        let%bind field_path = list_to_nsepseq field_path in
+        let field_path : CST.projection = {struct_name; selector=rg;field_path} in
+        let field_path = CST.Path (wrap @@ field_path) in
+        let record : CST.path = Name record in
+        let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+        let updates = wrap @@ ne_inject braces @@ (wrap update,[]) in
+        let update : CST.update = {lbrace=rg;record;kwd_with=rg;updates;rbrace=rg} in
+        return_expr @@ CST.EUpdate (wrap update)
+      )
+    )
+  | E_ascription {anno_expr;type_annotation} ->
+    let%bind expr = decompile_expression anno_expr in
+    let%bind ty   = decompile_type_expr type_annotation in
+    return_expr @@ CST.EAnnot (wrap @@ par (expr,rg,ty))
+  | E_cond {condition;then_clause;else_clause} ->
+    let%bind test  = decompile_expression condition in
+    let%bind ifso  = decompile_expression then_clause in
+    let%bind ifnot = decompile_expression else_clause in
+    let ifnot = Some(rg,ifnot) in
+    let cond : CST.cond_expr = {kwd_if=rg;test;kwd_then=rg;ifso;ifnot} in
+    return_expr @@ CST.ECond (wrap cond)
+  | E_sequence {expr1;expr2} ->
+    let%bind expr1 = decompile_expression expr1 in
+    let%bind expr2 = decompile_expression expr2 in
+    return_expr @@ CST.ESeq (wrap @@ inject beginEnd @@ list_to_sepseq [expr1; expr2])
+  | E_tuple tuple ->
+    let%bind tuple = bind_map_list decompile_expression tuple in
+    let%bind tuple = list_to_nsepseq tuple in
+    return_expr @@ CST.ETuple (wrap @@ tuple)
+  | E_map map ->
+    let%bind map = bind_map_list (bind_map_pair decompile_expression) map in
+    let aux (k,v) = CST.ETuple (wrap (k,[(rg,v)])) in
+    let map = List.map aux map in
+    (match map with 
+      [] -> return_expr @@ CST.EVar (wrap "Big_map.empty")
+    | _  ->
+      let var = CST.EVar (wrap "Map.literal") in
+      return_expr @@ CST.ECall (wrap @@ (var, List.Ne.of_list @@ map))
+    )
+  | E_big_map big_map ->
+    let%bind big_map = bind_map_list (bind_map_pair decompile_expression) big_map in
+    let aux (k,v) = CST.ETuple (wrap (k,[(rg,v)])) in
+    let big_map = List.map aux big_map in
+    (match big_map with 
+      [] -> return_expr @@ CST.EVar (wrap "Big_map.empty")
+    | _  ->
+      let var = CST.EVar (wrap "Big_map.literal") in
+      return_expr @@ CST.ECall (wrap @@ (var, List.Ne.of_list @@ big_map))
+    )
+  | E_list lst ->
+    let%bind lst = bind_map_list decompile_expression lst in
+    let lst = list_to_sepseq lst in
+    return_expr @@ CST.EList (EListComp (wrap @@ inject brackets @@ lst))
+  | E_set set ->
+    let%bind set = bind_map_list decompile_expression set in
+    let set = List.Ne.of_list @@ set in
+    let var = CST.EVar (wrap "Set.literal") in
+    return_expr @@ CST.ECall (wrap @@ (var,set))
+    (* We should avoid to generate skip instruction*)
+  | E_skip -> return_expr @@ CST.EUnit (wrap (rg,rg))
+  | E_assign _
+  | E_for _
+  | E_for_each _
+  | E_while _ ->
+    failwith @@ Format.asprintf "Decompiling a imperative construct to CameLIGO %a"
+    AST.PP.expression expr
+
+and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access ->
+  let struct_name = decompile_variable var in
+  match access with
+    [] -> ok @@ CST.Name struct_name
+  | lst ->
+    let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection lst in
+    let path : CST.projection = {struct_name;selector=rg;field_path} in
+    ok @@ (CST.Path (wrap @@ path) : CST.path)
+
+and decompile_to_selection : AST.access -> (CST.selection, _) result = fun access ->
+  match access with
+    Access_tuple index -> ok @@ CST.Component (wrap @@ ("",index))
+  | Access_record str  -> ok @@ CST.FieldName (wrap str)
+  | Access_map _ ->
+    failwith @@ Format.asprintf
+    "Can't decompile access_map to selection"
+
+and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} ->
+    let%bind param_decl = pattern_type binder input_type in
+    let param = (param_decl, []) in
+    let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in
+    let%bind return = decompile_expression result in
+    ok @@ (param,ret_type,None,return)
+
+and decompile_attributes = function
+    true -> [wrap "inline"]
+  | false -> []
+
+and decompile_matching_cases : AST.matching_expr -> ((CST.expr CST.case_clause Region.reg, Region.t) Parser_shared.Utils.nsepseq Region.reg,_) result = 
+fun m ->
+  let%bind cases = match m with
+    Match_variable (var, ty_opt, expr) ->
+    let%bind pattern = pattern_type var ty_opt in 
+    let%bind rhs = decompile_expression expr in
+    let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
+    ok @@ [wrap case]
+  | Match_tuple (lst, ty_opt, expr) ->
+    let%bind tuple = match ty_opt with 
+      Some ty_lst ->
+      let aux (var, ty) = 
+        let pattern = CST.PVar (decompile_variable var) in
+        let%bind type_expr = decompile_type_expr ty in
+        ok @@ CST.PTyped (wrap @@ CST.{pattern;colon=rg;type_expr}) 
+      in
+      bind list_to_nsepseq @@ bind_map_list aux @@ List.combine lst ty_lst
+    | None ->
+      let aux var = CST.PVar (decompile_variable var) in
+      list_to_nsepseq @@ List.map aux lst 
+    in
+    let pattern : CST.pattern = PTuple (wrap @@ tuple) in 
+    let%bind rhs = decompile_expression expr in
+    let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
+    ok @@ [wrap case]
+  | Match_record _ -> failwith "match_record not availiable yet"
+  | Match_option {match_none;match_some}->
+    let%bind rhs = decompile_expression match_none in
+    let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in
+    let%bind rhs = decompile_expression @@ snd match_some in
+    let var = CST.PVar (decompile_variable @@ fst match_some)in
+    let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in
+    ok @@ [wrap some_case;wrap none_case]
+  | Match_list {match_nil; match_cons} ->
+    let (hd,tl,expr) = match_cons in
+    let hd = CST.PVar (decompile_variable hd) in
+    let tl = CST.PVar (decompile_variable tl) in
+    let cons = (hd,rg,tl) in
+    let%bind rhs = decompile_expression @@ expr in
+    let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in
+    let%bind rhs = decompile_expression @@ match_nil in
+    let nil_case : _ CST.case_clause = {pattern=PList (PListComp (wrap @@ inject brackets None));arrow=rg; rhs} in
+    ok @@ [wrap cons_case; wrap nil_case]
+  | Match_variant lst ->
+    let aux ((c,v),e) = 
+      let AST.Constructor c = c in
+      let constr = wrap @@ c in
+      let var : CST.pattern = PVar (decompile_variable v) in
+      let tuple = var in
+      let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in
+      let%bind rhs = decompile_expression e in
+      let case : _ CST.case_clause = {pattern;arrow=rg;rhs} in
+      ok @@ wrap case
+    in
+    bind_map_list aux lst
+  in
+  map wrap @@ list_to_nsepseq cases
+let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _) result = fun decl ->
+  let decl = Location.unwrap decl in
+  let wrap value = ({value;region=Region.ghost} : _ Region.reg) in
+  match decl with
+    Declaration_type (name, te) ->
+    let name = decompile_variable name in
+    let%bind type_expr = decompile_type_expr te in
+    ok @@ CST.TypeDecl (wrap (CST.{kwd_type=rg; name; eq=rg; type_expr}))
+  | Declaration_constant (var, ty_opt, inline, expr) ->
+    let attributes : CST.attributes = decompile_attributes inline in
+    let var = CST.PVar (decompile_variable var) in
+    let binders = (var,[]) in
+    match expr.expression_content with
+      E_lambda lambda ->
+      let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
+      let%bind let_rhs = decompile_expression @@ AST.make_e @@ AST.E_lambda lambda in
+      let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
+      let let_decl : CST.let_decl = wrap (rg,None,let_binding,attributes) in
+      ok @@ CST.Let let_decl
+    | E_recursive {lambda; _} ->
+      let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
+      let%bind let_rhs = decompile_expression @@ AST.make_e @@ AST.E_lambda lambda in
+      let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
+      let let_decl : CST.let_decl = wrap (rg,Some rg,let_binding,attributes) in
+      ok @@ CST.Let (let_decl)
+    | _ ->
+      let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
+      let%bind let_rhs = decompile_expression expr in
+      let let_binding : CST.let_binding = {binders;lhs_type;eq=rg;let_rhs} in
+      let let_decl : CST.let_decl = wrap (rg,None,let_binding,attributes) in
+      ok @@ CST.Let let_decl
+
+let decompile_program : AST.program -> (CST.ast, _) result = fun prg ->
+  let%bind decl = bind_map_list decompile_declaration prg in
+  let decl = List.Ne.of_list decl in
+  ok @@ ({decl;eof=rg}: CST.ast)

src/passes/03-tree_abstraction/pascaligo/compiler.ml

@@ -418,6 +418,11 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
     let (language, _) = r_split language in
     let%bind code = compile_expression ci.code in
     return @@ e_raw_code ~loc language code
+  | EBlock be ->
+    let be, _ = r_split be in
+    let%bind next = compile_expression be.expr in
+    compile_block ~next be.block
+
 
 and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ =
 fun compiler cases ->
@@ -497,11 +502,11 @@ fun compiler cases ->
     return @@ AST.Match_variant (List.combine constrs lst)
   | (p, _), _ -> fail @@ unsupported_pattern_type p
 
-let compile_attribute_declaration = function
+and compile_attribute_declaration = function
   None   -> return false
 | Some _ -> return true
 
-let compile_parameters (params : CST.parameters) =
+and compile_parameters (params : CST.parameters) =
   let compile_param_decl (param : CST.param_decl) =
     match param with
       ParamConst pc ->
@@ -519,10 +524,10 @@ let compile_parameters (params : CST.parameters) =
   let params = npseq_to_list params.inside in
   bind_map_list compile_param_decl params
 
-let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result  = fun ?next instruction ->
+and compile_instruction : ?next: AST.expression -> CST.instruction -> _ result  = fun ?next instruction ->
   let return expr = match next with 
-    Some e -> return @@ e_sequence expr e
+    Some e -> ok @@ e_sequence expr e
-  | None -> return expr
+  | None -> ok @@ expr 
   in
   let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
     let (lst, loc) = r_split tuple_expr in
@@ -734,16 +739,13 @@ and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun
     Some block -> return block
   | None -> fail @@ block_start_with_attribute block
 
-and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) =
+and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attributes}: CST.fun_decl) =
   let%bind attr = compile_attribute_declaration attributes in
   let (fun_name, loc) = r_split fun_name in
   let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in
   let%bind param = compile_parameters param in
-  let%bind r     = compile_expression r in
+  let%bind result    = compile_expression r in
   let (param, param_type) = List.split param in
-  let%bind body = Option.unopt ~default:(return r) @@
-    Option.map (compile_block ~next:r <@ fst) block_with
-  in
   (* This handle the parameter case *)
   let (lambda,fun_type) = (match param_type with
     ty::[] ->
@@ -751,18 +753,18 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
       binder = (Var.of_name @@ List.hd param);
       input_type  = ty ;
       output_type = ret_type ;
-      result = body;
+      result;
     } in
     lambda,Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type)
   | lst ->
     let lst = Option.bind_list lst in
     let input_type = Option.map t_tuple lst in
-    let binder = Var.fresh ~name:"parameter" () in
+    let binder = Var.fresh ~name:"parameters" () in
     let lambda : AST.lambda = {
       binder;
       input_type = input_type;
       output_type = ret_type;
-      result = e_matching_tuple_ez (e_variable binder) param lst body;
+      result = e_matching_tuple_ez (e_variable binder) param lst result;
     } in
     lambda,Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type)
   )

src/passes/03-tree_abstraction/pascaligo/decompiler.ml

@@ -0,0 +1,660 @@
+module AST = Ast_imperative
+module CST = Cst.Pascaligo
+module Predefined = Predefined.Tree_abstraction.Pascaligo
+
+open Trace
+
+(* General tools *)
+let (<@) f g x = f (g x)
+
+(* Utils *)
+let rg = Region.ghost
+let wrap : type a. a -> a CST.reg = fun value -> {value;region=rg}
+let list_to_sepseq lst =
+  match lst with
+    [] -> None
+  |  hd :: lst -> 
+      let aux e = (rg, e) in
+      Some (hd, List.map aux lst)
+let list_to_nsepseq lst = 
+  match list_to_sepseq lst with
+    Some s -> ok @@ s
+  | None   -> failwith "List is not a non_empty list"
+let nelist_to_npseq (hd, lst) = (hd, List.map (fun e -> (rg, e)) lst)
+let npseq_cons hd lst = hd,(rg, fst lst)::(snd lst)
+
+let par a = CST.{lpar=rg;inside=a;rpar=rg}
+let braces a = CST.{lbrace=rg;inside=a;rbrace=rg}
+let brackets a = CST.{lbracket=rg;inside=a;rbracket=rg}
+let inject kind a = CST.{kind;enclosing=Brackets (rg,rg);elements=a;terminator=Some(rg)}
+let ne_inject kind a = CST.{kind;enclosing=Brackets (rg,rg);ne_elements=a;terminator=Some(rg)}
+let prefix_colon a = (rg, a)
+let suffix_with a = (a, rg)
+let to_block a = CST.{enclosing=Block (rg,rg,rg);statements=a;terminator=Some rg}
+let empty_block = to_block (CST.Instr (CST.Skip rg),[])
+
+(* Decompiler *)
+
+let decompile_variable : type a. a Var.t -> CST.variable = fun var ->
+  let var = Format.asprintf "%a" Var.pp var in
+  if String.contains var '#' then
+    let var = String.split_on_char '#' var in
+    wrap @@ "gen__" ^ (String.concat "" var)
+  else 
+    if String.length var > 4 && String.equal "gen__" @@ String.sub var 0 5 then
+      wrap @@ "user__" ^ var
+    else
+      wrap @@ var
+
+let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
+  let return te = ok @@ te in
+  match te.type_content with
+    T_sum sum ->
+    let sum = AST.CMap.to_kv_list sum in
+    let aux (AST.Constructor c, AST.{ctor_type;_}) =
+      let constr = wrap c in 
+      let%bind arg = decompile_type_expr ctor_type in
+      let arg = Some (rg, arg) in
+      let variant : CST.variant = {constr;arg} in
+      ok @@ wrap variant 
+    in
+    let%bind sum = bind_map_list aux sum in
+    let%bind sum = list_to_nsepseq sum in
+    return @@ CST.TSum (wrap sum)
+  | T_record record -> 
+    let record = AST.LMap.to_kv_list record in
+    let aux (AST.Label c, AST.{field_type;_}) =
+      let field_name = wrap c in 
+      let colon = rg in
+      let%bind field_type = decompile_type_expr field_type in
+      let variant : CST.field_decl = {field_name;colon;field_type} in
+      ok @@ wrap variant 
+    in
+    let%bind record = bind_map_list aux record in
+    let%bind record = list_to_nsepseq record in
+    return @@ CST.TRecord (wrap @@ ne_inject (NEInjRecord rg) record)
+  | T_tuple tuple ->
+    let%bind tuple = bind_map_list decompile_type_expr tuple in
+    let%bind tuple = list_to_nsepseq @@ tuple in
+    return @@ CST.TProd (wrap tuple)
+  | T_arrow {type1;type2} ->
+    let%bind type1 = decompile_type_expr type1 in
+    let%bind type2 = decompile_type_expr type2 in
+    let arrow = (type1, rg, type2) in
+    return @@ CST.TFun (wrap arrow)
+  | T_variable var ->
+    let var = decompile_variable var in
+    return @@ CST.TVar (var)
+  | T_constant const ->
+    let const = Predefined.type_constant_to_string const in
+    return @@ CST.TVar (wrap const)
+  | T_operator (operator, lst) ->
+    let operator = wrap @@ Predefined.type_operator_to_string operator in
+    let%bind lst = bind_map_list decompile_type_expr lst in
+    let%bind lst = list_to_nsepseq lst in
+    let lst : _ CST.par = {lpar=rg;inside=lst;rpar=rg} in
+    return @@ CST.TApp (wrap (operator,wrap lst))
+  | T_annoted _annot ->
+    failwith "let's work on it later"
+
+let get_e_variable : AST.expression -> _ result = fun expr ->
+  match expr.expression_content with 
+    E_variable var -> ok @@ var
+  | _ -> failwith @@ 
+    Format.asprintf "%a should be a variable expression"
+    AST.PP.expression expr
+ 
+let rec get_e_accessor : AST.expression -> _ result = fun expr ->
+  match expr.expression_content with 
+    E_variable var -> ok @@ (var, [])
+  | E_accessor {record;path} ->
+    let%bind (var, lst) = get_e_accessor record in
+    ok @@ (var, lst @ path)
+  | _ -> failwith @@ 
+    Format.asprintf "%a should be a variable expression"
+    AST.PP.expression expr
+
+let get_e_tuple : AST.expression -> _ result = fun expr ->
+  match expr.expression_content with 
+    E_tuple tuple -> ok @@ tuple
+  | E_variable _
+  | E_literal _
+  | E_constant _
+  | E_lambda _ -> ok @@ [expr]
+  | _ -> failwith @@ 
+    Format.asprintf "%a should be a tuple expression"
+    AST.PP.expression expr
+type eos =
+| Expression
+| Statements
+
+type state = Cst_pascaligo.ParserLog.state
+
+let statements_of_expression : CST.expr -> CST.statement List.Ne.t option = fun stat ->
+  match stat with
+  | CST.ECall call -> Some (CST.Instr (CST.ProcCall call), [])
+  | _ -> None
+
+let rec decompile_expression : AST.expression -> _ result = fun e ->
+  let%bind (block,expr) = decompile_to_block e in
+  match expr with
+    Some expr -> 
+    ( match block with
+      Some block ->
+        let block = wrap @@ block in
+        ok @@ CST.EBlock (wrap @@ CST.{block;kwd_with=rg;expr})
+    | None -> ok @@ expr
+    )
+  | None ->
+    failwith @@ Format.asprintf 
+      "An expression was expected, but this was decompile to statements. \n
+      Expr : %a
+      Loc : %a"
+      AST.PP.expression e
+      Location.pp e.location
+
+and decompile_statements : AST.expression -> _ result = fun expr ->
+  let%bind (stat,_) = decompile_eos Statements expr in
+  match stat with
+    Some stat -> ok @@ stat
+  | None -> 
+      failwith @@ Format.asprintf 
+        "Statements was expected, but this was decompile to expression. \n
+        Expr : %a
+        Loc : %a"
+        AST.PP.expression expr
+        Location.pp expr.location
+
+and decompile_to_block : AST.expression -> _ result = fun expr ->
+  let to_block a = CST.{enclosing=Block (rg,rg,rg);statements=a;terminator=Some rg} in
+  let%bind (stats,next) = decompile_eos Expression expr in
+  let block = Option.map (to_block <@ nelist_to_npseq) stats in
+  ok @@ (block, next)
+
+and decompile_to_tuple_expr : AST.expression list -> (CST.tuple_expr,_) result = fun expr ->
+  let%bind tuple_expr = bind_map_list decompile_expression expr in
+  let%bind tuple_expr = list_to_nsepseq tuple_expr in
+  let tuple_expr : CST.tuple_expr = wrap @@ par @@  tuple_expr in
+  ok @@ tuple_expr
+
+and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)* (CST.expr option), _) result = fun output expr ->
+  let return (a,b) = ok @@ (a,b) in
+  let return_expr expr = return @@ (None, Some expr) in
+  let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in
+  let return_stat stat = return @@ (Some stat, None) in
+  let return_stat_ez stat = return_stat @@ (stat, []) in
+  let return_inst inst = return_stat_ez @@ CST.Instr inst in
+  match expr.expression_content with
+    E_variable name -> 
+    let var = decompile_variable name in
+    return_expr @@ CST.EVar (var)
+  | E_constant {cons_name; arguments} ->
+    let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in
+    (match arguments with
+      [] -> return_expr @@ expr
+    | _ ->
+      let%bind arguments = decompile_to_tuple_expr arguments in
+      let const : CST.fun_call = wrap (expr, arguments) in
+      (match output with 
+        Expression -> return_expr (CST.ECall const)
+      | Statements -> return_inst (CST.ProcCall const)
+      )
+    )
+  | E_literal literal ->
+    (match literal with
+        Literal_unit  ->  return_expr @@ CST.EUnit rg
+      | Literal_int i ->  return_expr @@ CST.EArith (Int (wrap ("",i)))
+      | Literal_nat n ->  return_expr @@ CST.EArith (Nat (wrap ("",n)))
+      | Literal_timestamp time -> 
+        let time = Tezos_utils.Time.Protocol.to_notation @@
+          Tezos_utils.Time.Protocol.of_seconds @@ Z.to_int64 time in
+          (* TODO combinators for CSTs. *)
+        let%bind ty = decompile_type_expr @@ AST.t_timestamp () in
+        let time = CST.EString (String (wrap time)) in
+        return_expr @@ CST.EAnnot (wrap @@ par (time, rg, ty))
+      | Literal_mutez mtez -> return_expr @@ CST.EArith (Mutez (wrap ("",mtez)))
+      | Literal_string (Standard str) -> return_expr @@ CST.EString (String   (wrap str))
+      | Literal_string (Verbatim ver) -> return_expr @@ CST.EString (Verbatim (wrap ver))
+      | Literal_bytes b ->
+        let b = Hex.of_bytes b in
+        let s = Hex.to_string b in
+        return_expr @@ CST.EBytes (wrap (s,b))
+      | Literal_address addr ->
+        let addr = CST.EString (String (wrap addr)) in
+        let%bind ty = decompile_type_expr @@ AST.t_address () in
+        return_expr @@ CST.EAnnot (wrap @@ par (addr,rg,ty))
+      | Literal_signature sign ->
+        let sign = CST.EString (String (wrap sign)) in
+        let%bind ty = decompile_type_expr @@ AST.t_signature () in
+        return_expr @@ CST.EAnnot (wrap @@ par (sign,rg,ty))
+      | Literal_key k ->
+        let k = CST.EString (String (wrap k)) in
+        let%bind ty = decompile_type_expr @@ AST.t_key () in
+        return_expr @@ CST.EAnnot (wrap @@ par (k,rg,ty))
+      | Literal_key_hash kh ->
+        let kh = CST.EString (String (wrap kh)) in
+        let%bind ty = decompile_type_expr @@ AST.t_key_hash () in
+        return_expr @@ CST.EAnnot (wrap @@ par (kh,rg,ty))
+      | Literal_chain_id _ 
+      | Literal_void
+      | Literal_operation _ ->
+        failwith "chain_id, void, operation are not created currently ?"
+    )
+  | E_application {lamb;args} ->
+    let%bind lamb = decompile_expression lamb in
+    let%bind args = bind decompile_to_tuple_expr @@ get_e_tuple args in
+    (match output with
+      Expression -> 
+      return_expr @@ CST.ECall (wrap (lamb,args))
+    | Statements ->
+      return_inst @@ CST.ProcCall (wrap (lamb,args))
+    )
+  | E_lambda lambda ->
+    let%bind (param,ret_type,return) = decompile_lambda lambda in
+    let fun_expr : CST.fun_expr = {kwd_function=rg;param;ret_type;kwd_is=rg;return} in
+    return_expr_with_par @@ CST.EFun (wrap @@ fun_expr)
+  | E_recursive _ ->
+    failwith "corner case : annonymous recursive function"
+  | E_let_in {let_binder;rhs={expression_content=E_update {record={expression_content=E_variable var;_};path;update};_};let_result;inline=_} when Var.equal (fst let_binder) var ->
+    let%bind lhs = (match List.rev path with
+      Access_map e :: path ->
+      let%bind path  = decompile_to_path var @@ List.rev path in
+      let%bind index = map (wrap <@ brackets) @@ decompile_expression e in
+      let mlu : CST.map_lookup = {path; index} in
+      ok @@ CST.MapPath (wrap @@ mlu)
+    | _ ->
+      let%bind path  = decompile_to_path var @@ path in
+      ok @@ (CST.Path (path) : CST.lhs)
+    )
+    in
+    let%bind rhs = decompile_expression update in
+    let assign : CST.assignment = {lhs;assign=rg;rhs} in
+    let assign = CST.Instr (CST.Assign (wrap @@ assign)) in
+    let%bind (stat,expr) = decompile_eos output let_result in
+    let stat = (match stat with
+      Some (stat) -> Some (List.Ne.cons assign stat)
+    | None -> Some (assign,[])
+    )
+    in
+    return @@ (stat,expr)
+  | E_let_in {let_binder;rhs;let_result;inline} ->
+    let%bind lin = decompile_to_data_decl let_binder rhs inline in
+    let%bind (lst, expr) = decompile_eos Expression let_result in
+    let lst = match lst with 
+      Some lst -> List.Ne.cons (CST.Data lin) lst
+    | None -> (CST.Data lin, [])
+    in
+    return @@ (Some lst, expr)
+  | E_raw_code {language; code} ->
+    let language = wrap @@ wrap @@ language in
+    let%bind code = decompile_expression code in
+    let ci : CST.code_inj = {language;code;rbracket=rg} in
+    return_expr @@ CST.ECodeInj (wrap ci)
+  | E_constructor {constructor;element} ->
+    let Constructor constr = constructor in
+    let constr = wrap constr in
+    let%bind element = bind decompile_to_tuple_expr @@ get_e_tuple element in
+    return_expr_with_par @@ CST.EConstr (ConstrApp (wrap (constr, Some element)))
+  | E_matching {matchee; cases} ->
+    let%bind expr  = decompile_expression matchee in
+    (match output with
+      Expression ->
+      let%bind cases = decompile_matching_expr decompile_expression cases in
+      let cases : _ CST.case = {kwd_case=rg;expr;kwd_of=rg;enclosing=End rg;lead_vbar=None;cases} in
+      return_expr @@ CST.ECase (wrap cases)
+    | Statements ->
+      let%bind cases = decompile_matching_expr decompile_if_clause cases in
+      let cases : _ CST.case = {kwd_case=rg;expr;kwd_of=rg;enclosing=End rg;lead_vbar=None;cases} in
+      return_inst @@ CST.CaseInstr (wrap cases)
+    )
+  | E_record record  ->
+    let record = AST.LMap.to_kv_list record in
+    let aux (AST.Label str, expr) = 
+      let field_name = wrap str in
+      let%bind field_expr = decompile_expression expr in
+      let field : CST.field_assignment = {field_name;assignment=rg;field_expr} in
+      ok @@ wrap field
+    in
+    let%bind record = bind_map_list aux record in
+    let%bind record = list_to_nsepseq record in
+    let record = ne_inject (NEInjRecord rg) record in
+    (* why is the record not empty ? *)
+    return_expr @@ CST.ERecord (wrap record)
+  | E_accessor {record; path} ->
+    (match List.rev path with
+      Access_map e :: [] ->
+      let%bind (var,lst) = get_e_accessor @@ record in
+      let%bind path = decompile_to_path var lst in
+      let%bind e = decompile_expression e in
+      let index = wrap @@ brackets @@ e in
+      let mlu : CST.map_lookup = {path;index} in
+      return_expr @@ CST.EMap(MapLookUp (wrap @@ mlu))
+    | Access_map e :: lst ->
+      let path = List.rev lst in
+      let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
+      let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
+      let proj : CST.projection = {struct_name;selector=rg;field_path} in
+      let path : CST.path = CST.Path (wrap proj) in
+      let%bind e = decompile_expression e in
+      let index = wrap @@ brackets @@ e in
+      let mlu : CST.map_lookup = {path;index} in
+      return_expr @@ CST.EMap(MapLookUp (wrap @@ mlu))
+    | _ ->
+      let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection path in
+       let%bind struct_name = map (decompile_variable) @@ get_e_variable record in
+      let proj : CST.projection = {struct_name;selector=rg;field_path} in
+      return_expr @@ CST.EProj (wrap proj)
+    )
+  (* Update on multiple field of the same record. may be removed by adding sugar *)
+  | E_update {record={expression_content=E_update _;_} as record;path;update} ->
+    let%bind record = decompile_expression record in
+    let%bind (record,updates) = match record with
+      CST.EUpdate {value;_} -> ok @@ (value.record,value.updates) 
+    | _ -> failwith @@ Format.asprintf "Inpossible case %a" AST.PP.expression expr 
+    in
+    let%bind var,path = match path with 
+      Access_record var::path -> ok @@ (var,path)
+    | _ -> failwith "Impossible case %a"
+    in
+    let%bind field_path = decompile_to_path (Var.of_name var) path in
+    let%bind field_expr = decompile_expression update in
+    let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+    let updates = updates.value.ne_elements in
+    let updates = wrap @@ ne_inject (NEInjRecord rg) @@ npseq_cons (wrap @@ field_assign) updates in
+    let update : CST.update = {record;kwd_with=rg;updates} in
+    return_expr @@ CST.EUpdate (wrap @@ update)
+  | E_update {record; path; update} ->
+    let%bind record = map (decompile_variable) @@ get_e_variable record in
+    let%bind field_expr = decompile_expression update in
+    let (struct_name,field_path) = List.Ne.of_list path in
+    (match field_path with
+      [] -> 
+      (match struct_name with
+        Access_record name ->
+        let record : CST.path = Name record in
+        let field_path = CST.Name (wrap name) in
+        let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+        let updates = wrap @@ ne_inject (NEInjRecord rg) @@ (wrap update,[]) in
+        let update : CST.update = {record;kwd_with=rg;updates;} in
+        return_expr @@ CST.EUpdate (wrap update)
+      | Access_tuple _ -> failwith @@ Format.asprintf "invalid tuple update %a" AST.PP.expression expr
+      | Access_map e ->
+        let%bind e = decompile_expression e in
+        let arg : CST.tuple_expr = wrap @@ par @@ nelist_to_npseq (field_expr,[e; CST.EVar record]) in
+        return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"), arg))
+      )
+    | _ ->
+      let%bind struct_name = match struct_name with
+          Access_record name -> ok @@ wrap name
+        | Access_tuple _ -> failwith @@ Format.asprintf "invalid tuple update %a" AST.PP.expression expr
+        | Access_map _ -> failwith @@ Format.asprintf "invalid map update %a" AST.PP.expression expr
+      in
+      (match List.rev field_path with
+        Access_map e :: lst ->
+        let field_path = List.rev lst in
+        let%bind field_path = bind_map_list decompile_to_selection field_path in
+        let%bind field_path = list_to_nsepseq field_path in
+        let field_path : CST.projection = {struct_name; selector=rg;field_path} in
+        let field_path = CST.EProj (wrap @@ field_path) in
+        let%bind e = decompile_expression e in
+        let arg = wrap @@ par @@ nelist_to_npseq (field_expr, [e; field_path]) in
+        return_expr @@ CST.ECall (wrap (CST.EVar (wrap "Map.add"),arg))
+      | _ ->
+        let%bind field_path = bind_map_list decompile_to_selection field_path in
+        let%bind field_path = list_to_nsepseq field_path in
+        let field_path : CST.projection = {struct_name; selector=rg;field_path} in
+        let field_path : CST.path = CST.Path (wrap @@ field_path) in
+        let record : CST.path = Name record in
+        let update : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
+        let updates = wrap @@ ne_inject (NEInjRecord rg) @@ (wrap update,[]) in
+        let update : CST.update = {record;kwd_with=rg;updates;} in
+        return_expr @@ CST.EUpdate (wrap update)
+      )
+    )
+  | E_ascription {anno_expr;type_annotation} ->
+    let%bind expr = decompile_expression anno_expr in
+    let%bind ty   = decompile_type_expr type_annotation in
+    return_expr @@ CST.EAnnot (wrap @@ par (expr,rg,ty))
+  | E_cond {condition;then_clause;else_clause} ->
+    let%bind test  = decompile_expression condition in
+    (match output with
+      Expression ->
+      let%bind ifso = decompile_expression then_clause in
+      let%bind ifnot = decompile_expression else_clause in
+      let cond : CST.cond_expr = {kwd_if=rg;test;kwd_then=rg;ifso;terminator=Some rg;kwd_else=rg;ifnot} in
+      return_expr @@ CST.ECond (wrap cond)
+    | Statements ->
+      let%bind ifso  = decompile_if_clause then_clause in
+      let%bind ifnot = decompile_if_clause else_clause in
+      let cond : CST.conditional = {kwd_if=rg;test;kwd_then=rg;ifso;terminator=Some rg; kwd_else=rg;ifnot} in
+      return_inst @@ CST.Cond (wrap cond)
+    )
+  | E_sequence {expr1;expr2} ->
+    let%bind expr1 = decompile_statements expr1 in
+    let%bind (expr2,next) = decompile_eos Statements expr2 in
+    let expr1 = Option.unopt ~default:expr1 @@ Option.map (List.Ne.append expr1) expr2 in
+    return @@ (Some expr1, next)
+  | E_skip -> return_inst @@ CST.Skip rg
+  | E_tuple tuple ->
+    let%bind tuple = bind_map_list decompile_expression tuple in
+    let%bind tuple = list_to_nsepseq tuple in
+    return_expr @@ CST.ETuple (wrap @@ par tuple)
+  | E_map map ->
+    let%bind map = bind_map_list (bind_map_pair decompile_expression) map in
+    let aux (k,v) =
+      let binding : CST.binding = {source=k;arrow=rg;image=v} in
+      wrap @@ binding
+    in
+    let map = list_to_sepseq @@ List.map aux map in
+    return_expr @@ CST.EMap (MapInj (wrap @@ inject (InjMap rg) @@ map))
+  | E_big_map big_map ->
+    let%bind big_map = bind_map_list (bind_map_pair decompile_expression) big_map in
+    let aux (k,v) =
+      let binding : CST.binding = {source=k;arrow=rg;image=v} in
+      wrap @@ binding
+    in
+    let big_map = list_to_sepseq @@ List.map aux big_map in
+    return_expr @@ CST.EMap (BigMapInj (wrap @@ inject (InjBigMap rg) @@ big_map))
+  | E_list lst ->
+    let%bind lst = bind_map_list decompile_expression lst in
+    let lst = list_to_sepseq lst in
+    return_expr @@ CST.EList (EListComp (wrap @@ inject (InjList rg) @@ lst))
+  | E_set set ->
+    let%bind set = bind_map_list decompile_expression set in
+    let set = list_to_sepseq set in
+    return_expr @@ CST.ESet (SetInj (wrap @@ inject (InjSet rg) @@ set))
+  | E_assign {variable;access_path;expression} ->
+    let%bind lhs = decompile_to_lhs variable access_path in
+    let%bind rhs = decompile_expression expression in
+    let assign : CST.assignment = {lhs;assign=rg;rhs} in
+    return_inst @@ Assign (wrap assign)
+  | E_for {binder;start;final;increment;body} ->
+    let binder     = decompile_variable binder in
+    let%bind init  = decompile_expression start in
+    let%bind bound = decompile_expression final in
+    let%bind step  = decompile_expression increment in
+    let step       = Some (rg, step) in
+    let%bind (block,_next) = decompile_to_block body in
+    let block = wrap @@ Option.unopt ~default:(empty_block) block in
+    let fl : CST.for_int = {kwd_for=rg;binder;assign=rg;init;kwd_to=rg;bound;step;block} in
+    return_inst @@ CST.Loop (For (ForInt (wrap fl)))
+  | E_for_each {binder;collection;collection_type;body} ->
+    let var = decompile_variable @@ fst binder in
+    let bind_to = Option.map (fun x -> (rg,decompile_variable x)) @@ snd binder in
+    let%bind expr = decompile_expression collection in
+    let collection = match collection_type with 
+      Map -> CST.Map rg | Set -> Set rg | List -> List rg in
+    let%bind (block,_next) = decompile_to_block body in
+    let block = wrap @@ Option.unopt ~default:(empty_block) block in
+    let fc : CST.for_collect = {kwd_for=rg;var;bind_to;kwd_in=rg;collection;expr;block} in
+    return_inst @@ CST.Loop (For (ForCollect (wrap fc)))
+  | E_while {condition;body} ->
+    let%bind cond  = decompile_expression condition in
+    let%bind (block,_next) = decompile_to_block body in
+    let block = wrap @@ Option.unopt ~default:(empty_block) block in
+    let loop : CST.while_loop = {kwd_while=rg;cond;block} in
+    return_inst @@ CST.Loop (While (wrap loop))
+
+and decompile_if_clause : AST.expression -> (CST.if_clause, _) result = fun e ->
+  let%bind clause = decompile_statements e in
+  match clause with 
+    CST.Instr instr,[] ->
+    ok @@ CST.ClauseInstr instr
+  | _ ->
+    let clause = nelist_to_npseq clause, Some rg in
+    ok @@ CST.ClauseBlock (ShortBlock (wrap @@ braces @@ clause))
+
+and decompile_to_data_decl : (AST.expression_variable * AST.type_expression option) -> AST.expression -> bool -> (CST.data_decl, _) result = fun (name,ty_opt) expr inline ->
+  let name = decompile_variable name in
+  let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
+  let attributes : CST.attr_decl option = match inline with 
+    true -> Some (wrap @@ ne_inject (NEInjAttr rg) @@ (wrap @@ "inline",[]))
+  | false -> None
+  in
+  let fun_name = name in
+  match expr.expression_content with 
+    E_lambda lambda ->
+    let%bind (param,ret_type,return) = decompile_lambda lambda in
+    let fun_decl : CST.fun_decl = {kwd_recursive=None;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
+    ok @@ CST.LocalFun (wrap fun_decl)
+  | E_recursive {lambda; _} ->
+    let%bind (param,ret_type,return) = decompile_lambda lambda in
+    let fun_decl : CST.fun_decl = {kwd_recursive=Some rg;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
+    ok @@ CST.LocalFun (wrap fun_decl)
+  | _ ->
+    let%bind init = decompile_expression expr in
+    let const_decl : CST.const_decl = {kwd_const=rg;name;const_type;equal=rg;init;terminator=Some rg; attributes} in
+    let data_decl  : CST.data_decl  =  LocalConst (wrap const_decl) in
+    ok @@ data_decl
+
+and decompile_to_lhs : AST.expression_variable -> AST.access list -> (CST.lhs, _) result = fun var access ->
+  match List.rev access with
+    [] -> ok @@ (CST.Path (Name (decompile_variable var)) : CST.lhs)
+  | hd :: tl -> 
+    match hd with 
+    | AST.Access_map e ->
+      let%bind path = decompile_to_path var @@ List.rev tl in
+      let%bind index = map (wrap <@ brackets) @@ decompile_expression e in
+      let mlu: CST.map_lookup = {path;index} in
+      ok @@ CST.MapPath (wrap @@ mlu)
+    | _ -> 
+      let%bind path = decompile_to_path var @@ access in
+      ok @@ (CST.Path (path) : CST.lhs)
+
+and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access ->
+  let struct_name = decompile_variable var in
+  match access with
+    [] -> ok @@ CST.Name struct_name
+  | lst ->
+    let%bind field_path = bind list_to_nsepseq @@ bind_map_list decompile_to_selection lst in
+    let path : CST.projection = {struct_name;selector=rg;field_path} in
+    ok @@ (CST.Path (wrap @@ path) : CST.path)
+
+and decompile_to_selection : AST.access -> (CST.selection, _) result = fun access ->
+  match access with
+    Access_tuple index -> ok @@ CST.Component (wrap @@ ("",index))
+  | Access_record str  -> ok @@ CST.FieldName (wrap str)
+  | Access_map _ ->
+    failwith @@ Format.asprintf
+    "Can't decompile access_map to selection"
+
+and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} ->
+    let var = decompile_variable binder in
+    let%bind param_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) input_type in
+    let param_const : CST.param_const = {kwd_const=rg;var;param_type} in
+    let param_decl : CST.param_decl = ParamConst (wrap param_const) in
+    let param = nelist_to_npseq (param_decl, []) in
+    let param : CST.parameters = wrap @@ par param in
+    let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in
+    let%bind return = decompile_expression result in
+    ok @@ (param,ret_type,return)
+
+and decompile_matching_expr : type a.(AST.expr ->(a,_) result) -> AST.matching_expr -> ((a CST.case_clause Region.reg, Region.t) Parser_shared.Utils.nsepseq Region.reg,_) result = 
+fun f m ->
+  let%bind cases = match m with
+    Match_variable (var, _ty_opt, expr) ->
+    let pattern : CST.pattern = PVar (decompile_variable var) in 
+    let%bind rhs = f expr in
+    let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
+    ok @@ [wrap case]
+  | Match_tuple (lst, _ty_opt, expr) ->
+    let aux var = CST.PVar (decompile_variable var) in
+    let%bind tuple = list_to_nsepseq @@ List.map aux lst in
+    let pattern : CST.pattern = PTuple (wrap @@ par @@ tuple) in 
+    let%bind rhs = f expr in
+    let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
+    ok @@ [wrap case]
+  | Match_record _ -> failwith "match_record not availiable yet"
+  | Match_option {match_none;match_some}->
+    let%bind rhs = f match_none in
+    let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in
+    let%bind rhs = f @@ snd match_some in
+    let var = wrap @@ par @@ CST.PVar (decompile_variable @@ fst match_some)in
+    let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in
+    ok @@ [wrap some_case;wrap none_case]
+  | Match_list {match_nil; match_cons} ->
+    let (hd,tl,expr) = match_cons in
+    let hd = CST.PVar (decompile_variable hd) in
+    let tl = CST.PVar (decompile_variable tl) in
+    let cons = (hd,[rg,tl]) in
+    let%bind rhs = f @@ expr in
+    let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in
+    let%bind rhs = f @@ match_nil in
+    let nil_case : _ CST.case_clause = {pattern=PList (PNil rg);arrow=rg; rhs} in
+    ok @@ [wrap cons_case; wrap nil_case]
+  | Match_variant lst ->
+    let aux ((c,v),e) = 
+      let AST.Constructor c = c in
+      let constr = wrap @@ c in
+      let var : CST.pattern = PVar (decompile_variable v) in
+      let tuple = wrap @@ par @@ (var,[]) in
+      let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in
+      let%bind rhs = f e in
+      let case : _ CST.case_clause = {pattern;arrow=rg;rhs} in
+      ok @@ wrap case
+    in
+    bind_map_list aux lst
+  in
+  map wrap @@ list_to_nsepseq cases
+let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _) result = fun decl ->
+  let decl = Location.unwrap decl in
+  let wrap value = ({value;region=Region.ghost} : _ Region.reg) in
+  match decl with
+    Declaration_type (name, te) ->
+    let kwd_type = Region.ghost
+    and name = decompile_variable name
+    and kwd_is = Region.ghost in
+    let%bind type_expr = decompile_type_expr te in
+    let terminator = Some Region.ghost in
+    ok @@ CST.TypeDecl (wrap (CST.{kwd_type; name; kwd_is; type_expr; terminator}))
+  | Declaration_constant (var, ty_opt, inline, expr) ->
+    let attributes = match inline with
+      true -> 
+        let attr = wrap "inline" in
+        let ne_inj : _ CST.ne_injection = 
+          {kind=NEInjAttr rg;enclosing=End rg;ne_elements=(attr, []);terminator=Some rg} in
+        let attr_decl = wrap ne_inj in
+        Some attr_decl
+    | false -> None
+    in
+    let name = decompile_variable var in
+    let fun_name = name in
+    match expr.expression_content with
+      E_lambda lambda ->
+      let%bind (param,ret_type,return) = decompile_lambda lambda in
+      let fun_decl : CST.fun_decl = {kwd_recursive=None;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
+      ok @@ CST.FunDecl (wrap fun_decl)
+    | E_recursive {lambda; _} ->
+      let%bind (param,ret_type,return) = decompile_lambda lambda in
+      let fun_decl : CST.fun_decl = {kwd_recursive=Some rg;kwd_function=rg;fun_name;param;ret_type;kwd_is=rg;return;terminator=Some rg;attributes} in
+      ok @@ CST.FunDecl (wrap fun_decl)
+    | _ ->
+      let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
+      let%bind init = decompile_expression expr in
+      let const_decl : CST.const_decl = {kwd_const=rg;name;const_type;equal=rg;init;terminator=Some rg; attributes} in
+      ok @@ CST.ConstDecl (wrap const_decl)
+
+let decompile_program : AST.program -> (CST.ast, _) result = fun prg ->
+  let%bind decl = bind_map_list decompile_declaration prg in
+  let decl = List.Ne.of_list decl in
+  ok @@ ({decl;eof=rg}: CST.ast)

src/passes/03-tree_abstraction/pascaligo/pascaligo.ml

@@ -2,7 +2,11 @@ module CST = Cst.Pascaligo
 module AST = Ast_imperative
 
 module Compiler   = Compiler
+module Decompiler = Decompiler
 module Errors = Errors
 
 let compile_program      = Compiler.compile_program
 let compile_expression   = Compiler.compile_expression
+
+let decompile_program    = Decompiler.decompile_program
+let decompile_expression = Decompiler.decompile_expression

src/passes/03-tree_abstraction/pascaligo/pascaligo.mli

@@ -6,10 +6,14 @@ module Errors = Errors
 
 open Trace
 
-(** Convert a concrete PascaLIGO expression AST to the imperative
+(** Convert a concrete PascaLIGO expression CST to the imperative
     expression AST used by the compiler. *)
-val compile_expression : CST.expr -> (AST.expr , Errors.abs_error) result
+val compile_expression : CST.expr -> (AST.expr, Errors.abs_error) result
 
-(** Convert a concrete PascaLIGO program AST to the miperative program
+(** Convert a concrete PascaLIGO program CST to the miperative program
     AST used by the compiler. *)
 val compile_program : CST.ast -> (AST.program, Errors.abs_error) result
+
+val decompile_expression : AST.expr -> (CST.expr, _) result
+
+val decompile_program : AST.program -> (CST.ast, _) result

src/passes/05-purification/compiler.ml

@@ -252,7 +252,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression,
       let%bind condition    = compile_expression condition in
       let%bind then_clause' = compile_expression then_clause in
       let%bind else_clause' = compile_expression else_clause in
-      let env = Var.fresh () in
+      let env = Var.fresh ~name:"env" () in
       let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in
       let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in
       let then_clause  = add_to_end then_clause (O.e_variable env) in
@@ -283,7 +283,9 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression,
     | I.E_assign {variable; access_path; expression} ->
       let%bind access_path = compile_path access_path in
       let%bind expression = compile_expression expression in
-      let rhs = O.e_update ~loc (O.e_variable ~loc variable) access_path expression in
+      let rhs = match access_path with
+        [] -> expression
+      | _  -> O.e_update ~loc (O.e_variable ~loc variable) access_path expression in
       ok @@ fun expr -> (match expr with 
        | None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ())
        | Some e -> O.e_let_in ~loc (variable, None) true false rhs e
@@ -328,7 +330,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
       let%bind match_none' = compile_expression match_none in
       let (n,expr) = match_some in
       let%bind expr' = compile_expression expr in
-      let env = Var.fresh () in
+      let env = Var.fresh ~name:"env" () in
       let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in
       let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in
       let match_none = add_to_end match_none (O.e_variable env) in
@@ -348,7 +350,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
       let%bind match_nil' = compile_expression match_nil in
       let (hd,tl,expr) = match_cons in
       let%bind expr' = compile_expression expr in
-      let env = Var.fresh () in
+      let env = Var.fresh ~name:"name" () in
       let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in
       let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in
       let match_nil = add_to_end match_nil (O.e_variable env) in
@@ -365,7 +367,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
       else
         return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')}
     | I.Match_variant lst ->
-      let env = Var.fresh () in
+      let env = Var.fresh ~name:"env" () in
       let aux fv ((c,n),expr) =
         let%bind expr = compile_expression expr in
         let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in
@@ -401,8 +403,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
       return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr)
  
 and compile_while I.{condition;body} =
-  let env_rec = Var.fresh () in
+  let env_rec = Var.fresh ~name:"env_rec" () in
-  let binder  = Var.fresh () in
+  let binder  = Var.fresh ~name:"binder"  () in
 
   let%bind cond = compile_expression condition in
   let ctrl = 
@@ -436,7 +438,7 @@ and compile_while I.{condition;body} =
 
 
 and compile_for I.{binder;start;final;increment;body} =
-  let env_rec = Var.fresh () in
+  let env_rec = Var.fresh ~name:"env_rec" () in
   (*Make the cond and the step *)
   let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) (I.t_bool ()) in
   let%bind cond = compile_expression cond in
@@ -481,8 +483,8 @@ and compile_for I.{binder;start;final;increment;body} =
   ok @@ restore_mutable_variable return_expr captured_name_list env_rec 
 
 and compile_for_each I.{binder;collection;collection_type; body} =
-  let env_rec = Var.fresh () in
+  let env_rec = Var.fresh ~name:"env_rec" () in
-  let args = Var.fresh () in
+  let args    = Var.fresh ~name:"args" () in
 
   let%bind element_names = ok @@ match snd binder with
     | Some v -> [fst binder;v]

src/passes/07-desugaring/compiler.ml

@@ -6,7 +6,7 @@ open Errors
 
 let rec compile_type_expression : I.type_expression -> (O.type_expression , desugaring_error) result =
   fun te ->
-  let return tc = ok @@ O.make_t ~loc:te.location tc in
+  let return tc = ok @@ O.make_t ~loc:te.location ~sugar:te tc in
   match te.type_content with
     | I.T_sum sum -> 
       let sum = I.CMap.to_kv_list sum in
@@ -48,9 +48,9 @@ let rec compile_type_expression : I.type_expression -> (O.type_expression , desu
       return @@ T_operator (type_operator, lst)
 
 let rec compile_expression : I.expression -> (O.expression , desugaring_error) result =
-  fun e ->
+  fun sugar ->
-  let return expr = ok @@ O.make_e ~loc:e.location expr in
+  let return expr = ok @@ O.make_e ~loc:sugar.location ~sugar expr in
-  match e.expression_content with
+  match sugar.expression_content with
     | I.E_literal literal   -> return @@ O.E_literal literal
     | I.E_constant {cons_name;arguments} -> 
       let%bind arguments = bind_map_list compile_expression arguments in
@@ -81,7 +81,7 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
       return @@ O.E_constructor {constructor;element}
     | I.E_matching {matchee; cases} ->
       let%bind matchee = compile_expression matchee in
-      compile_matching e.location matchee cases
+      compile_matching sugar matchee cases
     | I.E_record record ->
       let record = I.LMap.to_kv_list record in
       let%bind record = 
@@ -93,33 +93,33 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
       return @@ O.E_record (O.LMap.of_list record)
     | I.E_accessor {record;path} ->
       let%bind record = compile_expression record in
-      let accessor ?loc e a =
+      let accessor ?loc expr a =
         match a with 
-          I.Access_tuple  i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
+          I.Access_tuple  i -> ok @@ O.e_record_accessor ?loc expr (Label (Z.to_string i))
-        | I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
+        | I.Access_record a -> ok @@ O.e_record_accessor ?loc expr (Label a)
         | I.Access_map k -> 
           let%bind k = compile_expression k in
-          ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
+          ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;expr]
       in
       bind_fold_list accessor record path
     | I.E_update {record;path;update} ->
       let%bind record = compile_expression record in
       let%bind update = compile_expression update in
-      let accessor ?loc e a =
+      let accessor ?loc expr a =
         match a with 
-          I.Access_tuple  i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
+          I.Access_tuple  i -> ok @@ O.e_record_accessor ?loc expr (Label (Z.to_string i))
-        | I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
+        | I.Access_record a -> ok @@ O.e_record_accessor ?loc expr (Label a)
         | I.Access_map k -> 
           let%bind k = compile_expression k in
-          ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
+          ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;expr]
       in
-      let updator ?loc (s:O.expression) a e =
+      let updator ?loc (s:O.expression) a expr =
         match a with
-          I.Access_tuple  i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) e
+          I.Access_tuple  i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) expr
-        | I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
+        | I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) expr
         | I.Access_map k ->
           let%bind k = compile_expression k in
-          ok @@ O.e_constant ?loc C_MAP_ADD [k;e;s]
+          ok @@ O.e_constant ?loc C_MAP_ADD [k;expr;s]
       in
       let aux (s, e : O.expression * _) lst =
         let%bind s' = accessor ~loc:s.location s lst in
@@ -176,7 +176,7 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
       let%bind expr1 = compile_expression expr1 in
       let%bind expr2 = compile_expression expr2 in
       return @@ O.E_let_in {let_binder=(Var.of_name "_", Some (O.t_unit ())); rhs=expr1;let_result=expr2; inline=false}
-    | I.E_skip -> ok @@ O.e_unit ~loc:e.location ()
+    | I.E_skip -> ok @@ O.e_unit ~loc:sugar.location ~sugar ()
     | I.E_tuple t ->
       let aux (i,acc) el = 
         let%bind el = compile_expression el in
@@ -191,19 +191,20 @@ and compile_lambda : I.lambda -> (O.lambda , desugaring_error) result =
     let%bind output_type = bind_map_option compile_type_expression output_type in
     let%bind result = compile_expression result in
     ok @@ O.{binder;input_type;output_type;result}
-and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expression, desugaring_error) result =
+and compile_matching : I.expression -> O.expression -> I.matching_expr -> (O.expression, desugaring_error) result =
-  fun loc e m -> 
+  fun sugar e m -> 
+  let loc = sugar.location in
   match m with 
     | I.Match_list {match_nil;match_cons} ->
       let%bind match_nil = compile_expression match_nil in
       let (hd,tl,expr) = match_cons in
       let%bind expr = compile_expression expr in
-      ok @@ O.e_matching ~loc e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)}
+      ok @@ O.e_matching ~loc ~sugar e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)}
     | I.Match_option {match_none;match_some} ->
       let%bind match_none = compile_expression match_none in
       let (n,expr) = match_some in
       let%bind expr = compile_expression expr in
-      ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)}
+      ok @@ O.e_matching ~loc ~sugar e @@ O.Match_option {match_none; match_some=(n,expr)}
     | I.Match_variant lst ->
       let%bind lst = bind_map_list (
         fun ((c,n),expr) ->
@@ -211,7 +212,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
           ok @@ ((c,n),expr)
       ) lst 
       in
-      ok @@ O.e_matching ~loc e @@ O.Match_variant lst
+      ok @@ O.e_matching ~loc ~sugar e @@ O.Match_variant lst
     | I.Match_record (fields,field_types, expr) ->
       let combine fields field_types =
         match field_types with
@@ -221,7 +222,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
       let%bind next   = compile_expression expr in
       let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
       let aux ((index,expr) : int * _ ) ((field,name): (O.label * (O.expression_variable * O.type_expression option))) =
-        let f = fun expr' -> O.e_let_in name false (O.e_record_accessor e field) expr' in
+        let f = fun expr' -> O.e_let_in ~sugar name false (O.e_record_accessor ~sugar e field) expr' in
         (index+1, fun expr' -> expr (f expr'))
       in
       let (_,header) = List.fold_left aux (0, fun e -> e) @@
@@ -238,7 +239,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
       let%bind next   = compile_expression expr in
       let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
       let aux ((index,expr) : int * _ ) (field: O.expression_variable * O.type_expression option) =
-        let f = fun expr' -> O.e_let_in field false (O.e_record_accessor e (Label (string_of_int index))) expr' in
+        let f = fun expr' -> O.e_let_in ~sugar field false (O.e_record_accessor ~sugar e (Label (string_of_int index))) expr' in
         (index+1, fun expr' -> expr (f expr'))
       in
       let (_,header) = List.fold_left aux (0, fun e -> e) @@
@@ -248,7 +249,7 @@ and compile_matching : Location.t -> O.expression -> I.matching_expr -> (O.expre
     | I.Match_variable (a, ty_opt, expr) ->
       let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
       let%bind expr = compile_expression expr in
-      ok @@ O.e_let_in (a,ty_opt) false e expr
+      ok @@ O.e_let_in ~sugar (a,ty_opt) false e expr
  
 let compile_declaration : I.declaration Location.wrap -> _ =
   fun {wrap_content=declaration;location} ->
@@ -257,7 +258,7 @@ let compile_declaration : I.declaration Location.wrap -> _ =
   | I.Declaration_constant (n, te_opt, inline, expr) ->
     let%bind expr = compile_expression expr in
     let%bind te_opt = bind_map_option compile_type_expression te_opt in
-    return @@ O.Declaration_constant (n, te_opt, inline, expr)
+    return @@ O.Declaration_constant (n, te_opt, {inline}, expr)
   | I.Declaration_type (n, te) ->
     let%bind te = compile_type_expression te in
     return @@ O.Declaration_type (n,te)

src/passes/07-desugaring/decompiler.ml

@@ -7,7 +7,10 @@ open Errors
 let rec decompile_type_expression : O.type_expression -> (I.type_expression, desugaring_error) result =
   fun te ->
   let return te = ok @@ I.make_t te in
-  match te.type_content with
+  match te.sugar with 
+    Some te -> ok @@ te
+  | None ->
+    match te.content with
       | O.T_sum sum -> 
         let sum = I.CMap.to_kv_list sum in
         let%bind sum = 
@@ -43,7 +46,10 @@ let rec decompile_type_expression : O.type_expression -> (I.type_expression, des
 let rec decompile_expression : O.expression -> (I.expression, desugaring_error) result =
   fun e ->
   let return expr = ok @@ I.make_e ~loc:e.location expr in
-  match e.expression_content with 
+  match e.sugar with
+    Some e -> ok @@ e
+  | None -> 
+    match e.content with 
       O.E_literal lit -> return @@ I.E_literal lit
     | O.E_constant {cons_name;arguments} -> 
       let%bind arguments = bind_map_list decompile_expression arguments in
@@ -134,7 +140,7 @@ and decompile_matching : O.matching_expr -> (I.matching_expr, desugaring_error)
 let decompile_declaration : O.declaration Location.wrap -> _ result = fun {wrap_content=declaration;location} ->
   let return decl = ok @@ Location.wrap ~loc:location decl in
   match declaration with 
-  | O.Declaration_constant (n, te_opt, inline, expr) ->
+  | O.Declaration_constant (n, te_opt, {inline}, expr) ->
     let%bind expr = decompile_expression expr in
     let%bind te_opt = bind_map_option decompile_type_expression te_opt in
     return @@ I.Declaration_constant (n, te_opt, inline, expr)

src/passes/08-self_ast_core/helpers.ml

@@ -3,7 +3,6 @@ open Trace
 open Stage_common.Helpers
 
 include Stage_common.PP
-include Stage_common.Types.Ast_generic_type(Ast_core_parameter)
 
 let bind_map_cmap f map = bind_cmap (
   CMap.map 
@@ -23,7 +22,7 @@ type ('a,'err) folder = 'a -> expression -> ('a, 'err) result
 let rec fold_expression : ('a, 'err) folder -> 'a -> expression -> ('a,'err) result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
-  match e.expression_content with
+  match e.content with
   | E_literal _ | E_variable _ | E_raw_code _ -> ok init'
   | E_constant {arguments=lst} -> (
     let%bind res = bind_fold_list self init' lst in
@@ -98,8 +97,8 @@ type 'err abs_mapper =
 let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
-  let return expression_content = ok { e' with expression_content } in
+  let return content = ok { e' with content } in
-  match e'.expression_content with
+  match e'.content with
   | E_ascription ascr -> (
       let%bind e' = self ascr.anno_expr in
       return @@ E_ascription {ascr with anno_expr=e'}
@@ -151,11 +150,11 @@ let rec map_expression : 'err exp_mapper -> expression -> (expression , 'err) re
   | E_literal _ | E_variable _ | E_raw_code _ as e' -> return e'
 
 and map_type_expression : 'err ty_exp_mapper -> type_expression -> (type_expression , 'err) result =
-    fun f ({type_content ; location ; type_meta} as te) ->
+    fun f ({content ; sugar; location } as te) ->
   let self = map_type_expression f in
   let%bind te' = f te in
-  let return type_content = ok { type_content; location ; type_meta } in
+  let return content = ok @@ ({ content; sugar; location}: type_expression) in
-  match type_content with
+  match content with
   | T_sum temap ->
     let%bind temap' = bind_map_cmap self temap in
     return @@ (T_sum temap')
@@ -212,8 +211,8 @@ let rec fold_map_expression : ('a , 'err) fold_mapper -> 'a -> expression -> ('a
   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
+  let return content = { e' with content } in
-  match e'.expression_content with
+  match e'.content with
   | E_ascription ascr -> (
       let%bind (res,e') = self init' ascr.anno_expr in
       ok (res, return @@ E_ascription {ascr with anno_expr=e'})

src/passes/09-typing/08-typer-new/typer.ml

@@ -24,7 +24,7 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st
     let%bind tv = evaluate_type env type_expression in
     let env' = Environment.add_type (type_name) tv env in
     ok (env', state , None)
-  | Declaration_constant (binder , tv_opt , inline, expression) -> (
+  | Declaration_constant (binder , tv_opt , attr, expression) -> (
     (*
       Determine the type of the expression and add it to the environment
     *)
@@ -33,7 +33,7 @@ let rec type_declaration env state : I.declaration -> (environment * O'.typer_st
         trace (constant_declaration_tracer binder expression tv'_opt) @@
         type_expression env state expression in
       let post_env = Environment.add_ez_declaration binder expr env in
-      ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
+      ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline=attr.inline} ))
     )
 
 and type_match : environment -> O'.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O'.typer_state, typer_error) result =
@@ -111,7 +111,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
 *)
 and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
   let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
-  match t.type_content with
+  match t.content with
   | T_arrow {type1;type2} ->
     let%bind type1 = evaluate_type e type1 in
     let%bind type2 = evaluate_type e type2 in
@@ -210,7 +210,7 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
     ok @@ (expr' , new_state) in
   let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
   trace (expression_tracer ae) @@
-  match ae.expression_content with
+  match ae.content with
 
   (* TODO: this file should take care only of the order in which program fragments
      are translated by Wrap.xyz

src/passes/09-typing/08-typer-new/wrap.ml

@@ -62,7 +62,7 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun
      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_content with
+  match te.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
      let tlist = List.map (fun ({ctor_type;_}:I.ctor_content) -> ctor_type) (I.CMap.to_list kvmap) in

src/passes/09-typing/08-typer-old/typer.ml

@@ -290,13 +290,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : O'.typer_state)
       let%bind tv = evaluate_type env type_expr in
       let env' = Environment.add_type (type_binder) tv env in
       ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } ))
-  | Declaration_constant (binder , tv_opt , inline, expression) -> (
+  | Declaration_constant (binder , tv_opt , attr, expression) -> (
       let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
       let%bind expr =
         trace (constant_declaration_error_tracer binder expression tv'_opt) @@
         type_expression' ?tv_opt:tv'_opt env expression in
       let post_env = Environment.add_ez_declaration binder expr env in
-      ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
+      ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline=attr.inline}))
     )
 
 and type_match : (environment -> I.expression -> (O.expression , typer_error) result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr, typer_error) result =
@@ -349,7 +349,7 @@ and type_match : (environment -> I.expression -> (O.expression , typer_error) re
 
 and evaluate_type (e:environment) (t:I.type_expression) : (O.type_expression, typer_error) result =
   let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in
-  match t.type_content with
+  match t.content with
   | T_arrow {type1;type2} ->
       let%bind type1 = evaluate_type e type1 in
       let%bind type2 = evaluate_type e type2 in
@@ -456,7 +456,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
     let location = ae.location in
     ok @@ make_e ~location expr tv in
   trace (expression_tracer ae) @@
-  match ae.expression_content with
+  match ae.content with
   (* Basic *)
   | E_variable name ->
       let%bind tv' =
@@ -561,7 +561,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
    return (E_lambda lambda ) lambda_type
   | E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ;
                 arguments=[
-                    ( { expression_content = (I.E_lambda { binder = lname ;
+                    ( { content = (I.E_lambda { binder = lname ;
                                                    input_type = None ; 
                                                    output_type = None ; 
                                                    result }) ;
@@ -589,7 +589,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
       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 ;
+                    ( { content = (I.E_lambda { binder = lname ;
                                                    input_type = None ; 
                                                    output_type = None ; 
                                                    result }) ;
@@ -701,7 +701,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
     return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
   | E_raw_code {language;code} ->
     let%bind (code,type_expression) = trace_option (expected_ascription code) @@
-      I.get_e_ascription code.expression_content in
+      I.get_e_ascription code.content in
     let%bind code = type_expression' e code in
     let%bind type_expression = evaluate_type e type_expression in
     let code = {code with type_expression} in
@@ -740,9 +740,9 @@ and type_lambda e {
           match input_type with
           | Some ty -> ok ty
           | None -> (
-              match result.expression_content with
+              match result.content with
               | I.E_let_in li -> (
-                  match li.rhs.expression_content with
+                  match li.rhs.content with
                   | I.E_variable name when name = (binder) -> (
                       match snd li.let_binder with
                       | Some ty -> ok ty
@@ -849,7 +849,7 @@ let rec untype_expression (e:O.expression) : (I.expression , typer_error) result
   | E_recursive {fun_name;fun_type; lambda} ->
       let%bind fun_type = untype_type_expression fun_type in
       let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in
-      let lambda = match unty_expr.expression_content with I.E_lambda l -> l | _ -> failwith "impossible case" in
+      let lambda = match unty_expr.content with I.E_lambda l -> l | _ -> failwith "impossible case" in
       return @@ e_recursive fun_name fun_type lambda
 
 and untype_matching : (O.expression -> (I.expression , typer_error) result) -> O.matching_expr -> (I.matching_expr , typer_error) result = fun f m ->

src/passes/10-self_ast_typed/helpers.ml

@@ -256,7 +256,7 @@ type contract_type = {
 let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program ->
   let aux declt = match Location.unwrap declt with
     | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
-       if String.equal (Var.to_name binder) main_fname
+       if Var.equal binder @@ Var.of_name main_fname
        then Some p
        else None
     | Declaration_type _ -> None

src/passes/predefined/predefined.ml

@@ -47,6 +47,23 @@ module Tree_abstraction = struct
     | "timestamp" -> Some TC_timestamp
     | _           -> None
 
+  let type_constant_to_string tc = 
+    match tc with
+      TC_chain_id  -> "chain_id"  
+    | TC_unit      -> "unit"      
+    | TC_string    -> "string"    
+    | TC_bytes     -> "bytes"     
+    | TC_nat       -> "nat"       
+    | TC_int       -> "int"       
+    | TC_mutez     -> "tez"       
+    | TC_operation -> "operation" 
+    | TC_address   -> "address"   
+    | TC_key       -> "key"       
+    | TC_key_hash  -> "key_hash"  
+    | TC_signature -> "signature" 
+    | TC_timestamp -> "timestamp" 
+    | TC_void      -> "void"
+
   let type_operators s =
     match s with
       "list"                      -> Some (TC_list)
@@ -61,6 +78,23 @@ module Tree_abstraction = struct
     | "michelson_or_left_comb"    -> Some (TC_michelson_or_left_comb)
     | _                           -> None
 
+  let type_operator_to_string s =
+    match s with
+      TC_list -> "list"                      
+    | TC_option -> "option"                    
+    | TC_set -> "set"                       
+    | TC_map -> "map"                       
+    | TC_big_map -> "big_map"                   
+    | TC_contract -> "contract"                  
+    | TC_michelson_pair -> "michelson_pair"
+    | TC_michelson_or -> "michelson_or"
+    | TC_michelson_pair_right_comb -> "michelson_pair_right_comb" 
+    | TC_michelson_pair_left_comb -> "michelson_pair_left_comb"  
+    | TC_michelson_or_right_comb -> "michelson_or_right_comb"   
+    | TC_michelson_or_left_comb -> "michelson_or_left_comb"    
+    | TC_map_or_big_map -> "map_or_big_map"
+    
+
   let pseudo_modules = function
     | "Tezos.chain_id"           -> Some C_CHAIN_ID
     | "Tezos.balance"            -> Some C_BALANCE
@@ -165,6 +199,113 @@ module Tree_abstraction = struct
     | _ -> None
 
 
+  let pseudo_module_to_string = function
+    | C_CHAIN_ID                -> "Tezos.chain_id"
+    | C_BALANCE                 -> "Tezos.balance"
+    | C_NOW                     -> "Tezos.now"
+    | C_AMOUNT                  -> "Tezos.amount"
+    | C_SENDER                  -> "Tezos.sender"
+    | C_ADDRESS                 -> "Tezos.address"
+    | C_SELF                    -> "Tezos.self"
+    | C_SELF_ADDRESS            -> "Tezos.self_address"
+    | C_IMPLICIT_ACCOUNT        -> "Tezos.implicit_account"
+    | C_SOURCE                  -> "Tezos.source"
+    | C_FAILWITH                -> "Tezos.failwith"
+    | C_CREATE_CONTRACT         -> "Tezos.create_contract"
+    | C_CALL                    -> "Tezos.transaction"
+    | C_SET_DELEGATE            -> "Tezos.set_delegate"
+    | C_CONTRACT_OPT            -> "Tezos.get_contract_opt"
+    | C_CONTRACT_ENTRYPOINT_OPT -> "Tezos.get_entrypoint_opt"
+    | C_CONTRACT                -> "Tezos.get_contract"
+    | C_CONTRACT_ENTRYPOINT     -> "Tezos.get_entrypoint"
+
+    (* Crypto module *)
+
+    | C_CHECK_SIGNATURE -> "Crypto.check"
+    | C_HASH_KEY        -> "Crypto.hash_key"
+    | C_BLAKE2b         -> "Crypto.blake2b"
+    | C_SHA256          -> "Crypto.sha256"
+    | C_SHA512          -> "Crypto.sha512"
+    
+    (* Bytes module *)
+
+    | C_BYTES_PACK   -> "Bytes.pack"
+    | C_BYTES_UNPACK -> "Bytes.unpack"
+    | C_SIZE         -> "Bytes.length"
+    | C_CONCAT       -> "Bytes.concat"
+    | C_SLICE        -> "Bytes.sub"
+
+    (* List module *)   
+
+  (*  | C_SIZE      -> "List.size" *)
+    | C_LIST_ITER -> "List.iter"
+    | C_LIST_MAP  -> "List.map"
+    | C_LIST_FOLD -> "List.fold"
+
+    (* Set module *)   
+
+    | C_SET_EMPTY   -> "Set.empty"
+    | C_SET_LITERAL -> "Set.literal"
+   (* | C_SIZE        -> "Set.cardinal"*)
+    | C_SET_MEM     -> "Set.mem"
+    | C_SET_ADD     -> "Set.add"
+    | C_SET_REMOVE  -> "Set.remove"
+    | C_SET_ITER    -> "Set.iter"
+    | C_SET_FOLD    -> "Set.fold"
+
+    (* Map module *)   
+
+    | C_MAP_FIND_OPT -> "Map.find_opt"
+    | C_MAP_UPDATE   -> "Map.update"
+    | C_MAP_ITER     -> "Map.iter"
+    | C_MAP_MAP      -> "Map.map"
+    | C_MAP_FOLD     -> "Map.fold"
+    | C_MAP_MEM      -> "Map.mem"
+  (*  | C_SIZE         -> "Map.size" *)
+    | C_MAP_ADD      -> "Map.add"
+    | C_MAP_REMOVE   -> "Map.remove"
+    | C_MAP_EMPTY    -> "Map.empty"
+    | C_MAP_LITERAL  -> "Map.literal"
+    
+    (* Big_map module *)   
+    
+    | C_MAP_FIND        -> "Big_map.find"
+  (*  | C_MAP_FIND_OPT    -> "Big_map.find_opt"
+    | C_MAP_UPDATE      -> "Big_map.update" *)
+    | C_BIG_MAP_LITERAL -> "Big_map.literal"
+    | C_BIG_MAP_EMPTY   -> "Big_map.empty"
+  (*  | C_MAP_MEM         -> "Big_map.mem"
+    | C_MAP_REMOVE      -> "Big_map.remove"
+    | C_MAP_ADD         -> "Big_map.add" *)
+
+    (* Bitwise module *)
+
+    | C_OR  -> "Bitwise.or"
+    | C_AND -> "Bitwise.and"
+    | C_XOR -> "Bitwise.xor"
+    | C_LSL -> "Bitwise.shift_left"
+    | C_LSR -> "Bitwise.shift_right"
+
+    (* String module *)
+
+  (*  | C_SIZE   -> "String.length" (* will never trigger, rename size *)
+    | C_SLICE  -> "String.sub"
+    | C_CONCAT -> "String.concat" *)
+
+    (* michelson pair/or type converter module *)
+
+    | C_CONVERT_TO_RIGHT_COMB   -> "Layout.convert_to_right_comb"
+    | C_CONVERT_TO_LEFT_COMB    -> "Layout.convert_to_left_comb"
+    | C_CONVERT_FROM_RIGHT_COMB -> "Layout.convert_from_right_comb"
+    | C_CONVERT_FROM_LEFT_COMB  -> "Layout.convert_from_left_comb"
+
+    (* Not parsed *)
+    | C_SOME -> "Some"
+    | C_NONE -> "None"
+
+    | _ as c -> failwith @@ Format.asprintf "Constant not handled : %a" Stage_common.PP.constant c 
+
+
   module Pascaligo = struct
     let constants = function
     (* Tezos module (ex-Michelson) *)
@@ -283,8 +424,46 @@ module Tree_abstraction = struct
 
     | _ as c            -> pseudo_modules c
 
+    let constant_to_string = function
+    (* Tezos module (ex-Michelson) *)
+    | C_FAILWITH -> "failwith"
+
+    | C_IS_NAT -> "is_nat"
+    | C_INT    -> "int"
+    | C_ABS    -> "abs"
+    | C_EDIV   -> "ediv"
+    | C_UNIT   -> "unit"
+
+    | C_NEG  -> "NEG"
+    | C_ADD  -> "ADD"
+    | C_SUB  -> "SUB"
+    | C_MUL  -> "TIMES"
+    | C_DIV  -> "DIV"
+    | C_MOD  -> "MOD"
+    | C_EQ   -> "EQ"
+    | C_NOT  -> "NOT"
+    | C_AND  -> "AND"
+    | C_OR   -> "OR"
+    | C_GT   -> "GT"
+    | C_GE   -> "GE"
+    | C_LT   -> "LT"
+    | C_LE   -> "LE"
+    | C_CONS -> "CONS"
+    | C_NEQ  -> "NEQ"
+
+    (*->  Others *)
+
+    | C_ASSERTION -> "assert"
+    
+    | C_CONVERT_TO_RIGHT_COMB -> "Layout.convert_to_right_comb"
+    | C_CONVERT_TO_LEFT_COMB  -> "Layout.convert_to_left_comb"
+
+    | _ as c            -> pseudo_module_to_string c
+
     let type_constants = type_constants
     let type_operators = type_operators
+    let type_constant_to_string = type_constant_to_string
+    let type_operator_to_string = type_operator_to_string
   end
 
   module Cameligo = struct
@@ -370,8 +549,43 @@ module Tree_abstraction = struct
 
     | _ as c -> pseudo_modules c
 
+    let constant_to_string = function
+    (* Tezos (ex-Michelson, ex-Current, ex-Operation) *)
+    | C_FAILWITH -> "failwith"
+    
+    | C_IS_NAT -> "is_nat"
+    | C_INT    -> "int"
+    | C_ABS    -> "abs"
+    | C_EDIV   -> "ediv"
+    | C_UNIT   -> "unit"
+
+    | C_NEG  -> "NEG"
+    | C_ADD  -> "ADD"
+    | C_SUB  -> "SUB"
+    | C_MUL  -> "TIMES"
+    | C_DIV  -> "DIV"
+    | C_MOD  -> "MOD"
+    | C_EQ   -> "EQ"
+    | C_NOT  -> "NOT"
+    | C_AND  -> "AND"
+    | C_OR   -> "OR"
+    | C_GT   -> "GT"
+    | C_GE   -> "GE"
+    | C_LT   -> "LT"
+    | C_LE   -> "LE"
+    | C_CONS -> "CONS"
+    | C_NEQ  -> "NEQ"
+
+    (* Others *)
+
+    | C_ASSERTION -> "assert"
+
+    | _ as c -> pseudo_module_to_string c
+
     let type_constants = type_constants
     let type_operators = type_operators
+    let type_constant_to_string = type_constant_to_string
+    let type_operator_to_string = type_operator_to_string
   end
 end
 

src/passes/predefined/predefined.mli

@@ -6,12 +6,18 @@ module Tree_abstraction : sig
     val constants      : string -> constant' option
     val type_constants : string -> type_constant option
     val type_operators : string -> type_operator option
+    val constant_to_string      : constant'     -> string
+    val type_constant_to_string : type_constant -> string
+    val type_operator_to_string : type_operator -> string
   end
 
   module Cameligo : sig
     val constants  : string -> constant' option
     val type_constants : string -> type_constant option
     val type_operators : string -> type_operator option
+    val constant_to_string      : constant'     -> string
+    val type_constant_to_string : type_constant -> string
+    val type_operator_to_string : type_operator -> string
   end
 
 end

src/stages/1-cst/cameligo/CST.ml

@@ -251,13 +251,13 @@ and expr =
 and annot_expr = expr * colon * type_expr
 
 and 'a injection = {
-  compound   : compound;
+  compound   : compound option;
   elements   : ('a, semi) sepseq;
   terminator : semi option
 }
 
 and 'a ne_injection = {
-  compound    : compound;
+  compound    : compound option;
   ne_elements : ('a, semi) nsepseq;
   terminator  : semi option
 }
@@ -395,8 +395,7 @@ and cond_expr = {
   test     : expr;
   kwd_then : kwd_then;
   ifso     : expr;
-  kwd_else : kwd_else;
+  ifnot    : (kwd_else * expr) option;
-  ifnot    : expr
 }
 
 (* Code injection.  Note how the field [language] wraps a region in

src/stages/1-cst/cameligo/ParserLog.ml

@@ -63,6 +63,11 @@ let print_sepseq :
         None -> ()
   | Some seq -> print_nsepseq state sep print seq
 
+let print_option : state -> (state -> 'a -> unit ) -> 'a option -> unit =
+  fun state print -> function
+    None -> ()
+  | Some opt -> print state opt
+
 let print_csv state print {value; _} =
   print_nsepseq state "," print value
 
@@ -74,7 +79,7 @@ let print_token state region lexeme =
 let print_var state {region; value} =
   let line =
     sprintf "%s: Ident %s\n"
-            (compact state region) value
+            (compact state region)value
   in Buffer.add_string state#buffer line
 
 let print_constr state {region; value} =
@@ -244,14 +249,18 @@ and print_ne_injection :
     print_close_compound state compound
 
 and print_open_compound state = function
+  None -> ()
+| Some compound -> match compound with
     BeginEnd (kwd_begin,_) -> print_token state kwd_begin "begin"
-| Braces   (lbrace,_)    -> print_token state lbrace    "{"
+  | Braces   (lbrace,_)    -> print_token state lbrace    "{"
-| Brackets (lbracket,_)  -> print_token state lbracket  "["
+  | Brackets (lbracket,_)  -> print_token state lbracket  "["
 
 and print_close_compound state = function
+  None -> ()
+| Some compound -> match compound with
     BeginEnd (_,kwd_end)  -> print_token state kwd_end  "end"
-| Braces   (_,rbrace)   -> print_token state rbrace   "}"
+  | Braces   (_,rbrace)   -> print_token state rbrace   "}"
-| Brackets (_,rbracket) -> print_token state rbracket "]"
+  | Brackets (_,rbracket) -> print_token state rbracket "]"
 
 and print_terminator state = function
   Some semi -> print_token state semi ";"
@@ -584,14 +593,17 @@ and print_fun_expr state {value; _} =
 
 and print_conditional state {value; _} =
   let {kwd_if; test; kwd_then;
-       ifso; kwd_else; ifnot} = value in
+       ifso; ifnot} = value in
   print_token state ghost "(";
   print_token state kwd_if "if";
   print_expr  state test;
   print_token state kwd_then "then";
   print_expr  state ifso;
+  print_option state 
+    (fun state (kwd_else,ifnot) -> 
       print_token state kwd_else "else";
       print_expr state ifnot;
+    ) ifnot;
   print_token state ghost ")"
 
 (* Conversion to string *)
@@ -1114,10 +1126,12 @@ and pp_cond_expr state (cond: cond_expr) =
     let state = state#pad 3 1 in
     pp_node state "<true>";
     pp_expr (state#pad 1 0) cond.ifso in
-  let () =
+  let () = match cond.ifnot with
+    Some (_, ifnot) ->
     let state = state#pad 3 2 in
     pp_node state "<false>";
-    pp_expr (state#pad 1 0) cond.ifnot
+    pp_expr (state#pad 1 0) ifnot
+  | None -> ()
   in ()
 
 and pp_case :

src/stages/1-cst/pascaligo/CST.ml

@@ -219,12 +219,17 @@ and fun_decl = {
   param         : parameters;
   ret_type      : (colon * type_expr) option;
   kwd_is        : kwd_is;
-  block_with    : (block reg * kwd_with) option;
   return        : expr;
   terminator    : semi option;
   attributes    : attr_decl option
 }
 
+and block_with = {
+  block    : block reg;
+  kwd_with : kwd_with;
+  expr     : expr;
+}
+
 and parameters = (param_decl, semi) nsepseq par reg
 
 and param_decl =
@@ -382,15 +387,13 @@ and 'a case_clause = {
 and assignment = {
   lhs    : lhs;
   assign : assign;
-  rhs    : rhs
+  rhs    : expr;
 }
 
 and lhs =
   Path    of path
 | MapPath of map_lookup reg
 
-and rhs = expr
-
 and loop =
   While of while_loop reg
 | For   of for_loop
@@ -465,6 +468,7 @@ and expr =
 | EPar     of expr par reg
 | EFun     of fun_expr reg
 | ECodeInj of code_inj reg
+| EBlock      of block_with reg
 
 and annot_expr = expr * colon * type_expr
 
@@ -691,7 +695,8 @@ let rec expr_to_region = function
 | ECond    {region; _}
 | EPar     {region; _}
 | EFun     {region; _}
-| ECodeInj {region; _} -> region
+| ECodeInj {region; _}
+| EBlock   {region; _} -> region
 
 and tuple_expr_to_region {region; _} = region
 
@@ -809,8 +814,6 @@ let lhs_to_region : lhs -> Region.t = function
   Path path -> path_to_region path
 | MapPath {region; _} -> region
 
-let rhs_to_region = expr_to_region
-
 let selection_to_region = function
   FieldName {region; _}
 | Component {region; _} -> region

src/stages/1-cst/pascaligo/ParserLog.ml

@@ -218,18 +218,13 @@ and print_type_tuple state {value; _} =
 
 and print_fun_decl state {value; _} =
   let {kwd_function; fun_name; param;
-       ret_type; kwd_is; block_with;
+       ret_type; kwd_is;
        return; terminator; _} = value in
   print_token      state kwd_function "function";
   print_var        state fun_name;
   print_parameters state param;
   print_option     state print_colon_type_expr  ret_type;
   print_token      state kwd_is "is";
-  (match block_with with
-    None -> ()
-  | Some (block, kwd_with) ->
-     print_block state block;
-     print_token state kwd_with "with");
   print_expr state return;
   print_terminator state terminator;
 
@@ -252,6 +247,12 @@ and print_code_inj state {value; _} =
   print_expr   state code;
   print_token  state rbracket "]"
 
+and print_block_expr state {value; _} =
+  let {block;kwd_with;expr} = value in
+  print_block state block;
+  print_token state kwd_with "with";
+  print_expr  state expr;
+
 and print_parameters state {value; _} =
   let {lpar; inside; rpar} = value in
   print_token state lpar "(";
@@ -475,6 +476,7 @@ and print_expr state = function
 | EPar     e -> print_par_expr state e
 | EFun     e -> print_fun_expr state e
 | ECodeInj e -> print_code_inj state e
+| EBlock   e -> print_block_expr state e
 
 and print_annot_expr state node =
   let {inside; _} : annot_expr par = node in
@@ -919,11 +921,11 @@ and pp_attr_decl state = pp_ne_injection pp_string state
 and pp_fun_decl state decl =
   let arity, start =
     match decl.kwd_recursive with
-      None -> 5,0
+      None -> 4,0
     | Some _ ->
-       let state = state#pad 6 0 in
+       let state = state#pad 5 0 in
        let () = pp_node state "recursive"
-       in 6,1 in
+       in 5,1 in
   let () =
     let state = state#pad arity start in
     pp_ident state decl.fun_name in
@@ -937,14 +939,6 @@ and pp_fun_decl state decl =
     print_option (state#pad 1 0) pp_type_expr @@ Option.map snd decl.ret_type in
   let () =
     let state = state#pad arity (start + 3) in
-    pp_node state "<body>";
-    let statements =
-      match decl.block_with with
-        Some (block,_) -> block.value.statements
-      | None -> Instr (Skip Region.ghost), [] in
-    pp_statements state statements in
-  let () =
-    let state = state#pad arity (start + 4) in
     pp_node state "<return>";
     pp_expr (state#pad 1 0) decl.return
   in ()
@@ -1039,6 +1033,19 @@ and pp_code_inj state rc =
     pp_expr (state#pad 1 0) rc.code
   in ()
 
+and pp_block_expr state (bw : block_with) =
+  let {block;expr;_}:CST.block_with = bw in
+  let () =
+    let state = state#pad 2 0 in
+    pp_node state "<block>";
+    pp_statements state block.value.statements
+  in
+  let () =
+    let state = state#pad 2 1 in
+    pp_node state "<expr>";
+    pp_expr (state#pad 1 0) expr in
+  ()
+
 and pp_parameters state {value; _} =
   let params = Utils.nsepseq_to_list value.inside in
   let arity  = List.length params in
@@ -1521,6 +1528,9 @@ and pp_expr state = function
 | ECodeInj {value; region} ->
     pp_loc_node state "ECodeInj" region;
     pp_code_inj state value;
+| EBlock {value; region} ->
+    pp_loc_node state "EBlock" region;
+    pp_block_expr state value;
 
 and pp_list_expr state = function
   ECons {value; region} ->

src/stages/1-cst/pascaligo/ParserLog.mli

@@ -19,6 +19,7 @@ val print_path        : state -> CST.path -> unit
 val print_pattern     : state -> CST.pattern -> unit
 val print_instruction : state -> CST.instruction -> unit
 val print_expr        : state -> CST.expr -> unit
+val print_statements  : state -> CST.statements -> unit
 
 (** {1 Printing tokens from the CST in a string} *)
 

src/stages/4-ast_core/PP.ml

@@ -2,16 +2,96 @@
 open Types
 open Format
 open PP_helpers
-
+module Helpers = Stage_common.Helpers
 include Stage_common.PP
-include Ast_PP_type(Ast_core_parameter)
+
+
+  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, {ctor_type;_}) = fprintf ppf "@[<h>%a -> %a@]" constructor k value ctor_type in
+    fprintf ppf "%a" (list_sep new_pp sep) lst
+  let cmap_sep_d x = cmap_sep x (tag " ,@ ")
+
+  let record_sep value sep ppf (m : 'a label_map) =
+    let lst = LMap.to_kv_list m in
+    let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
+    let new_pp ppf (k, {field_type;_}) = fprintf ppf "@[<h>%a -> %a@]" label k value field_type 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 = Helpers.tuple_of_record m in
+    let new_pp ppf (_, {field_type;_}) = fprintf ppf "%a" value field_type in
+    fprintf ppf "%a" (list_sep new_pp sep) lst
+
+  let record_sep_expr value sep ppf (m : 'a label_map) =
+    let lst = LMap.to_kv_list m in
+    let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
+    let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
+    fprintf ppf "%a" (list_sep new_pp sep) lst
+
+  let tuple_sep_expr value sep ppf m =
+    assert (Helpers.is_tuple_lmap m);
+    let lst = Helpers.tuple_of_record m in
+    let new_pp ppf (_,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_t 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 (tag sep_tuple)) m
+  else
+    fprintf ppf format_record (record_sep value (tag sep_record)) m
+
+let tuple_or_record_sep_expr value format_record sep_record format_tuple sep_tuple ppf m =
+  if Helpers.is_tuple_lmap m then
+    fprintf ppf format_tuple (tuple_sep_expr value (tag sep_tuple)) m
+  else
+    fprintf ppf format_record (record_sep_expr value (tag sep_record)) m
+
+let tuple_or_record_sep_expr value = tuple_or_record_sep_expr value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
+let tuple_or_record_sep_type value = tuple_or_record_sep_t value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
+
+let rec type_content : formatter -> type_expression -> unit =
+  fun ppf te ->
+  match te.content with
+  | T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d type_expression) m
+  | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type type_expression) m
+  | T_arrow a -> fprintf ppf "%a -> %a" type_expression a.type1 type_expression a.type2
+  | T_variable tv -> type_variable ppf tv
+  | T_constant tc -> type_constant ppf tc
+  | T_operator to_ -> type_operator type_expression ppf to_
+
+and type_expression ppf (te : type_expression) : unit =
+  fprintf ppf "%a" type_content te
+
+and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit =
+  fun f ppf to_ ->
+  let s = match to_ with
+    TC_option                    , lst -> Format.asprintf "option(%a)"                     (list_sep_d f) lst
+  | TC_list                      , lst -> Format.asprintf "list(%a)"                       (list_sep_d f) lst
+  | TC_set                       , lst -> Format.asprintf "set(%a)"                        (list_sep_d f) lst
+  | TC_map                       , lst -> Format.asprintf "Map (%a)"                       (list_sep_d f) lst
+  | TC_big_map                   , lst -> Format.asprintf "Big Map (%a)"                   (list_sep_d f) lst
+  | TC_map_or_big_map            , lst -> Format.asprintf "Map Or Big Map (%a)"            (list_sep_d f) lst
+  | TC_contract                  , lst -> Format.asprintf "Contract (%a)"                  (list_sep_d f) lst
+  | TC_michelson_pair            , lst -> Format.asprintf "michelson_pair (%a)"            (list_sep_d f) lst                            
+  | TC_michelson_or              , lst -> Format.asprintf "michelson_or (%a)"              (list_sep_d f) lst
+  | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst
+  | TC_michelson_pair_left_comb  , lst -> Format.asprintf "michelson_pair_left_comb (%a)"  (list_sep_d f) lst
+  | TC_michelson_or_right_comb   , lst -> Format.asprintf "michelson_or_right_comb (%a)"   (list_sep_d f) lst
+  | TC_michelson_or_left_comb    , lst -> Format.asprintf "michelson_or_left_comb (%a)"    (list_sep_d f) lst
+  in
+  fprintf ppf "(type_operator: %s)" s
 
 let expression_variable ppf (ev : expression_variable) : unit =
   fprintf ppf "%a" Var.pp ev
 
 
 let rec expression ppf (e : expression) =
-  expression_content ppf e.expression_content
+  expression_content ppf e.content
 and expression_content ppf (ec : expression_content) =
   match ec with
   | E_literal l ->
@@ -109,10 +189,10 @@ let declaration ppf (d : declaration) =
   match d with
   | Declaration_type (type_name, te) ->
       fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te
-  | Declaration_constant (name, ty_opt, i, expr) ->
+  | Declaration_constant (name, ty_opt, attr, expr) ->
       fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression
         expr
-        option_inline i
+        option_inline attr.inline
 
 let program ppf (p : program) =
   fprintf ppf "@[<v>%a@]"

src/stages/4-ast_core/combinators.ml

@@ -3,109 +3,108 @@ module Option = Simple_utils.Option
 
 module SMap = Map.String
 
-let make_t ?(loc = Location.generated) type_content = {type_content; location=loc; type_meta = ()}
+let make_t ?(loc = Location.generated) ?sugar content = ({content; sugar; location=loc}: type_expression)
 
 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 ?loc ()        : type_expression = make_t ?loc @@ T_variable (Stage_common.Constant.t_bool)
+let t_bool      ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_variable (Stage_common.Constant.t_bool)
-let t_string ?loc ()      : type_expression = make_t ?loc @@ T_constant (TC_string)
+let t_string    ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_string)
-let t_bytes ?loc ()       : type_expression = make_t ?loc @@ T_constant (TC_bytes)
+let t_bytes     ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_bytes)
-let t_int ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_int)
+let t_int       ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_int)
-let t_operation ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_operation)
+let t_operation ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_operation)
-let t_nat ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_nat)
+let t_nat       ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_nat)
-let t_tez ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_mutez)
+let t_tez       ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_mutez)
-let t_unit ?loc ()        : type_expression = make_t ?loc @@ T_constant (TC_unit)
+let t_unit      ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_unit)
-let t_address ?loc ()     : type_expression = make_t ?loc @@ T_constant (TC_address)
+let t_address   ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_address)
-let t_signature ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_signature)
+let t_signature ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_signature)
-let t_key ?loc ()         : type_expression = make_t ?loc @@ T_constant (TC_key)
+let t_key       ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_key)
-let t_key_hash ?loc ()    : type_expression = make_t ?loc @@ T_constant (TC_key_hash)
+let t_key_hash  ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_key_hash)
-let t_timestamp ?loc ()   : type_expression = make_t ?loc @@ T_constant (TC_timestamp)
+let t_timestamp ?loc ?sugar () : type_expression = make_t ?loc ?sugar @@ T_constant (TC_timestamp)
-let t_option ?loc o       : type_expression = make_t ?loc @@ T_operator (TC_option, [o])
+let t_option    ?loc ?sugar o  : type_expression = make_t ?loc ?sugar @@ T_operator (TC_option, [o])
-let t_list ?loc t         : type_expression = make_t ?loc @@ T_operator (TC_list, [t])
+let t_list      ?loc ?sugar t  : type_expression = make_t ?loc ?sugar @@ T_operator (TC_list, [t])
-let t_variable ?loc n     : type_expression = make_t ?loc @@ T_variable (Var.of_name n)
+let t_variable  ?loc ?sugar n  : type_expression = make_t ?loc ?sugar @@ T_variable (Var.of_name n)
-let t_record_ez ?loc lst =
+let t_record_ez ?loc ?sugar lst =
   let lst = List.map (fun (k, v) -> (Label k, v)) lst in
   let m = LMap.of_list lst in
-  make_t ?loc @@ T_record m
+  make_t ?loc ?sugar @@ T_record m
-let t_record ?loc m  : type_expression =
+let t_record ?loc ?sugar m  : type_expression =
   let lst = Map.String.to_kv_list m in
-  t_record_ez ?loc lst
+  t_record_ez ?loc ?sugar lst
 
-let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [("0",a) ; ("1",b)]
+let t_pair  ?loc ?sugar (a , b) : type_expression = t_record_ez ?loc ?sugar [("0",a) ; ("1",b)]
-let t_tuple ?loc lst    : type_expression = t_record_ez ?loc (tuple_to_record lst)
+let t_tuple ?loc ?sugar lst     : type_expression = t_record_ez ?loc ?sugar (tuple_to_record lst)
 
-let ez_t_sum ?loc (lst:(string * ctor_content) list) : type_expression =
+let ez_t_sum ?loc ?sugar (lst:(string * ctor_content) 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
-  make_t ?loc @@ T_sum map
+  make_t ?loc ?sugar @@ T_sum map
-let t_sum ?loc m : type_expression =
+let t_sum ?loc ?sugar m : type_expression =
   let lst = Map.String.to_kv_list m in
-  ez_t_sum ?loc lst
+  ez_t_sum ?loc ?sugar lst
 
-let t_function ?loc type1 type2  : type_expression = make_t ?loc @@ T_arrow {type1; type2}
+let t_function ?loc ?sugar type1 type2  : type_expression = make_t ?loc ?sugar @@ T_arrow {type1; type2}
+let t_operator ?loc ?sugar op lst       : type_expression = make_t ?loc ?sugar @@ T_operator (op, lst)
+let t_map      ?loc ?sugar key value    : type_expression = make_t ?loc ?sugar @@ T_operator (TC_map, [key; value])
+let t_big_map  ?loc ?sugar key value    : type_expression = make_t ?loc ?sugar @@ T_operator (TC_big_map, [key; value])
+let t_set      ?loc ?sugar key          : type_expression = make_t ?loc ?sugar @@ T_operator (TC_set, [key])
+let t_contract ?loc ?sugar contract     : type_expression = make_t ?loc ?sugar @@ T_operator (TC_contract, [contract])
 
-let t_operator ?loc op lst       : type_expression = make_t ?loc @@ T_operator (op, lst)
+let make_e ?(loc = Location.generated) ?sugar content = {content; sugar; location=loc }
-let t_map ?loc key value         : type_expression = make_t ?loc @@ T_operator (TC_map, [key; value])
-let t_big_map ?loc key value     : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value])
-let t_set ?loc key               : type_expression = make_t ?loc @@ T_operator (TC_set, [key])
-let t_contract ?loc contract     : type_expression = make_t ?loc @@ T_operator (TC_contract, [contract])
 
-let make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc }
+let e_var       ?loc ?sugar n  : expression = make_e ?loc ?sugar @@ E_variable (Var.of_name n)
-
+let e_literal   ?loc ?sugar l  : expression = make_e ?loc ?sugar @@ E_literal l
-let e_var ?loc (n: string) : expression = make_e ?loc @@ E_variable (Var.of_name n)
+let e_unit      ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_literal (Literal_unit)
-let e_literal ?loc l : expression = make_e ?loc @@ E_literal l
+let e_int       ?loc ?sugar n  : expression = make_e ?loc ?sugar @@ E_literal (Literal_int n)
-let e_unit ?loc () : expression = make_e ?loc @@ E_literal (Literal_unit)
+let e_nat       ?loc ?sugar n  : expression = make_e ?loc ?sugar @@ E_literal (Literal_nat n)
-let e_int ?loc n : expression = make_e ?loc @@ E_literal (Literal_int n)
+let e_timestamp ?loc ?sugar n  : expression = make_e ?loc ?sugar @@ E_literal (Literal_timestamp n)
-let e_nat ?loc n : expression = make_e ?loc @@ E_literal (Literal_nat n)
+let e_string    ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_string s)
-let e_timestamp ?loc n : expression = make_e ?loc @@ E_literal (Literal_timestamp n)
+let e_address   ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_address s)
-let e_string ?loc s : expression = make_e ?loc @@ E_literal (Literal_string s)
+let e_mutez     ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_mutez s)
-let e_address ?loc s : expression = make_e ?loc @@ E_literal (Literal_address s)
+let e_signature ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_signature s)
-let e_mutez ?loc s : expression = make_e ?loc @@ E_literal (Literal_mutez s)
+let e_key       ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_key s)
-let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signature s)
+let e_key_hash  ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_key_hash s)
-let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s)
+let e_chain_id  ?loc ?sugar s  : expression = make_e ?loc ?sugar @@ E_literal (Literal_chain_id s)
-let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s)
-let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s)
 let e'_bytes b : expression_content =
   let bytes = Hex.to_bytes (`Hex b) in
   E_literal (Literal_bytes bytes)
-let e_bytes_hex ?loc b : expression =
+let e_bytes_hex ?loc ?sugar b : expression =
   let e' = e'_bytes b in
-  make_e ?loc e'
+  make_e ?loc ?sugar e'
-let e_bytes_raw ?loc (b: bytes) : expression =
+let e_bytes_raw ?loc ?sugar (b: bytes) : expression =
-  make_e ?loc @@ E_literal (Literal_bytes b)
+  make_e ?loc ?sugar @@ E_literal (Literal_bytes b)
-let e_bytes_string ?loc (s: string) : expression =
+let e_bytes_string ?loc ?sugar (s: string) : expression =
-  make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
+  make_e ?loc ?sugar @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
-let e_some ?loc s  : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
+let e_some       ?loc ?sugar s        : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_SOME; arguments = [s]}
-let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
+let e_none       ?loc ?sugar ()       : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_NONE; arguments = []}
-let e_string_cat ?loc sl sr : expression = make_e ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
+let e_string_cat ?loc ?sugar sl sr    : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
-let e_map_add ?loc k v old  : expression = make_e ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
+let e_map_add    ?loc ?sugar k v old  : expression = make_e ?loc ?sugar @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
 
-let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
+let e_constant    ?loc ?sugar name lst                             = make_e ?loc ?sugar @@ E_constant {cons_name=name ; arguments = lst}
-let e_variable ?loc v = make_e ?loc @@ E_variable v
+let e_variable    ?loc ?sugar v                                    = make_e ?loc ?sugar @@ E_variable v
-let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
+let e_application ?loc ?sugar a b                                  = make_e ?loc ?sugar @@ E_application {lamb=a ; args=b}
-let e_lambda ?loc binder input_type output_type result =  make_e ?loc @@ E_lambda {binder; input_type; output_type; result ;  }
+let e_lambda      ?loc ?sugar binder input_type output_type result = make_e ?loc ?sugar @@ E_lambda {binder; input_type; output_type; result ;  }
-let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
+let e_recursive   ?loc ?sugar fun_name fun_type lambda             = make_e ?loc ?sugar @@ E_recursive {fun_name; fun_type; lambda}
-let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
+let e_let_in      ?loc ?sugar (binder, ascr) inline rhs let_result = make_e ?loc ?sugar @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
-let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code}
+let e_raw_code    ?loc ?sugar language code                        = make_e ?loc ?sugar @@ E_raw_code {language; code}
 
-let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
+let e_constructor ?loc ?sugar s a : expression = make_e ?loc ?sugar @@ E_constructor { constructor = Constructor s; element = a}
-let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
+let e_matching    ?loc ?sugar a b : expression = make_e ?loc ?sugar @@ E_matching {matchee=a;cases=b}
 
-let e_record ?loc map = make_e ?loc @@ E_record map
+let e_record          ?loc ?sugar map = make_e ?loc ?sugar @@ E_record map
-let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = b}
+let e_record_accessor ?loc ?sugar a b = make_e ?loc ?sugar @@ E_record_accessor {record = a; path = b}
-let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
+let e_record_update   ?loc ?sugar record path update = make_e ?loc ?sugar @@ E_record_update {record; path; update}
 
-let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
+let e_annotation ?loc ?sugar anno_expr ty = make_e ?loc ?sugar @@ E_ascription {anno_expr; type_annotation = ty}
 
-let e_bool ?loc   b : expression = e_constructor ?loc (string_of_bool b) (e_unit ())
+let e_bool ?loc ?sugar b : expression = e_constructor ?loc ?sugar (string_of_bool b) (e_unit ())
 
-let make_option_typed ?loc e t_opt =
+let make_option_typed ?loc ?sugar e t_opt =
   match t_opt with
   | None -> e
-  | Some t -> e_annotation ?loc e t
+  | Some t -> e_annotation ?loc ?sugar e t
 
 let e_typed_none ?loc t_opt =
   let type_annotation = t_option t_opt in
@@ -139,7 +138,7 @@ let get_e_list = fun t ->
   let rec aux t = 
     match t with
       E_constant {cons_name=C_CONS;arguments=[key;lst]} -> 
-        let lst = aux lst.expression_content in
+        let lst = aux lst.content in
         (Some key)::(lst)
     | E_constant {cons_name=C_LIST_EMPTY;arguments=[]} ->
         []
@@ -161,7 +160,7 @@ let get_e_ascription = fun a ->
 
 (* Same as get_e_pair *)
 let extract_pair : expression -> (expression * expression) option = fun e ->
-  match e.expression_content with
+  match e.content with
   | E_record r -> ( 
   let lst = LMap.to_kv_list r in
     match lst with 
@@ -173,13 +172,13 @@ let extract_pair : expression -> (expression * expression) option = fun e ->
   | _ -> None
 
 let extract_record : expression -> (label * expression) list option = fun e ->
-  match e.expression_content with
+  match e.content with
   | E_record lst -> Some (LMap.to_kv_list lst)
   | _ -> None
 
 let extract_map : expression -> (expression * expression) list option = fun e ->
   let rec aux e =
-    match e.expression_content with
+    match e.content with
       E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} -> 
         let map = aux map in
         (Some (k,v))::map 

src/stages/4-ast_core/combinators.mli

@@ -1,86 +1,86 @@
 open Types
 
-val make_t      : ?loc:Location.t -> type_content -> type_expression
+val make_t      : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_content -> type_expression
-val t_bool      : ?loc:Location.t -> unit -> type_expression
+val t_bool      : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_string    : ?loc:Location.t -> unit -> type_expression
+val t_string    : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_bytes     : ?loc:Location.t -> unit -> type_expression
+val t_bytes     : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_int       : ?loc:Location.t -> unit -> type_expression
+val t_int       : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_operation : ?loc:Location.t -> unit -> type_expression
+val t_operation : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_nat       : ?loc:Location.t -> unit -> type_expression
+val t_nat       : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_tez       : ?loc:Location.t -> unit -> type_expression
+val t_tez       : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_unit      : ?loc:Location.t -> unit -> type_expression
+val t_unit      : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_address   : ?loc:Location.t -> unit -> type_expression
+val t_address   : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_key       : ?loc:Location.t -> unit -> type_expression
+val t_key       : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_key_hash  : ?loc:Location.t -> unit -> type_expression
+val t_key_hash  : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_timestamp : ?loc:Location.t -> unit -> type_expression
+val t_timestamp : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
-val t_signature : ?loc:Location.t -> unit -> type_expression
+val t_signature : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> unit -> type_expression
 (*
 val t_option    : type_expression -> type_expression
 *)
-val t_list      : ?loc:Location.t -> type_expression -> type_expression
+val t_list      : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression
-val t_variable  : ?loc:Location.t -> string -> type_expression
+val t_variable  : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> string -> type_expression
 (*
 val t_record    : te_map -> type_expression
 *)
-val t_pair   : ?loc:Location.t -> ( field_content * field_content ) -> type_expression
+val t_pair   : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> ( field_content * field_content ) -> type_expression
-val t_tuple  : ?loc:Location.t -> field_content list -> type_expression
+val t_tuple  : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> field_content list -> type_expression
 
-val t_record    : ?loc:Location.t -> field_content Map.String.t -> type_expression
+val t_record    : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> field_content Map.String.t -> type_expression
-val t_record_ez : ?loc:Location.t -> (string * field_content) list -> type_expression
+val t_record_ez : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> (string * field_content) list -> type_expression
 
-val t_sum    : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expression
+val t_sum    : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> Types.ctor_content Map.String.t -> type_expression
-val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression
+val ez_t_sum : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> ( string * Types.ctor_content ) list -> type_expression
 
-val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_function : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression
 
-val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression
+val t_operator : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_operator -> type_expression list -> type_expression
-val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_map : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression
-val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression
+val t_big_map : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression -> type_expression
-val t_contract : ?loc:Location.t -> type_expression -> type_expression
+val t_contract : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression
-val t_set      : ?loc:Location.t -> type_expression -> type_expression
+val t_set      : ?loc:Location.t -> ?sugar:Ast_sugar.type_expression -> type_expression -> type_expression
 
-val make_e : ?loc:Location.t -> expression_content -> expression
+val make_e         : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_content -> expression
-val e_var : ?loc:Location.t -> string -> expression
+val e_var          : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
-val e_literal : ?loc:Location.t -> literal -> expression
+val e_literal      : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> literal -> expression
-val e_unit : ?loc:Location.t -> unit -> expression
+val e_unit         : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> unit -> expression
-val e_int : ?loc:Location.t -> Z.t -> expression 
+val e_int          : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression 
-val e_nat : ?loc:Location.t -> Z.t -> expression
+val e_nat          : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
-val e_timestamp : ?loc:Location.t -> Z.t -> expression
+val e_timestamp    : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
-val e_bool : ?loc:Location.t -> bool -> expression
+val e_bool         : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> bool -> expression
-val e_string : ?loc:Location.t -> ligo_string -> expression
+val e_string       : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> ligo_string -> expression
-val e_address : ?loc:Location.t -> string -> expression 
+val e_address      : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression 
-val e_signature : ?loc:Location.t -> string -> expression 
+val e_signature    : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression 
-val e_key : ?loc:Location.t -> string -> expression 
+val e_key          : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression 
-val e_key_hash : ?loc:Location.t -> string -> expression 
+val e_key_hash     : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression 
-val e_chain_id : ?loc:Location.t -> string -> expression 
+val e_chain_id     : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression 
-val e_mutez : ?loc:Location.t -> Z.t -> expression
+val e_mutez        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> Z.t -> expression
 val e'_bytes       : string -> expression_content
-val e_bytes_hex : ?loc:Location.t -> string -> expression
+val e_bytes_hex    : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
-val e_bytes_raw : ?loc:Location.t -> bytes -> expression
+val e_bytes_raw    : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> bytes -> expression
-val e_bytes_string : ?loc:Location.t -> string -> expression
+val e_bytes_string : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression
 
-val e_some : ?loc:Location.t -> expression -> expression
+val e_some            : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression
-val e_none : ?loc:Location.t -> unit -> expression
+val e_none            : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> unit -> expression
-val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
+val e_string_cat      : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression
-val e_map_add : ?loc:Location.t -> expression -> expression ->  expression -> expression
+val e_map_add         : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression ->  expression -> expression
-val e_constructor : ?loc:Location.t -> string -> expression -> expression
+val e_constructor     : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -> expression
-val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
+val e_matching        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> matching_expr -> expression
-val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
+val e_record_accessor : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> label -> expression
-val e_variable : ?loc:Location.t -> expression_variable -> expression
+val e_variable        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> expression
-val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
+val e_let_in          : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
-val e_raw_code : ?loc:Location.t -> string -> expression -> expression
+val e_raw_code        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> string -> expression -> expression
-val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
+val e_annotation      : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> type_expression -> expression
-val e_application : ?loc:Location.t -> expression -> expression -> expression
+val e_application     : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> expression -> expression
-val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
+val e_constant        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> constant' -> expression list -> expression
 
-val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
+val make_option_typed : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> type_expression option -> expression
 
 val e_typed_none      : ?loc:Location.t -> type_expression -> expression
 
-val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
+val e_lambda        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
-val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
+val e_recursive     : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression_variable -> type_expression -> lambda -> expression
-val e_record : ?loc:Location.t -> expr label_map-> expression
+val e_record        : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expr label_map-> expression
-val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
+val e_record_update : ?loc:Location.t -> ?sugar:Ast_sugar.expression -> expression -> label -> expression -> expression
 
 val assert_e_record_accessor : expression_content -> unit option
 

src/stages/4-ast_core/dune

@@ -5,6 +5,7 @@
     simple-utils
     tezos-utils
     stage_common
+    ast_sugar
   )
   (preprocess
     (pps ppx_let bisect_ppx --conditional)

src/stages/4-ast_core/misc.ml

@@ -97,7 +97,7 @@ let assert_literal_eq (a, b : literal * literal) : unit option =
   | Literal_chain_id _, _ -> None
 
 let rec assert_value_eq (a, b: (expression * expression )) : unit option =
-  match (a.expression_content , b.expression_content) with
+  match (a.content , b.content) with
   | E_literal a , E_literal b ->
     assert_literal_eq (a, b)
   | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (

src/stages/4-ast_core/types.ml

@@ -2,15 +2,11 @@
 
 module Location = Simple_utils.Location
 
-module Ast_core_parameter = struct
-  type type_meta = unit
-end
-
 include Stage_common.Types
 
-include Ast_generic_type (Ast_core_parameter)
+type attribute = {
-
+  inline: bool
-type inline = bool 
+} 
 type program = declaration Location.wrap list
 and declaration =
   | Declaration_type of (type_variable * type_expression)
@@ -20,10 +16,35 @@ and declaration =
    *   an optional type annotation
    *   a boolean indicating whether it should be inlined
    *   an expression *)
-  | Declaration_constant of (expression_variable * type_expression option * inline * expression)
+  | Declaration_constant of (expression_variable * type_expression option * attribute * expression)
 
 (* | Macro_declaration of macro_declaration *)
-and expression = {expression_content: expression_content; location: Location.t}
+
+
+and type_content =
+  | T_sum of ctor_content constructor_map
+  | T_record of field_content label_map
+  | T_arrow of arrow
+  | T_variable of type_variable
+  | T_constant of type_constant
+  | T_operator of (type_operator * type_expression list)
+
+and arrow = {type1: type_expression; type2: type_expression}
+and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int}
+and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int}
+
+and type_expression = {
+  content  : type_content; 
+  sugar    : Ast_sugar.type_expression option;
+  location : Location.t;
+  }
+
+
+and expression = {
+  content  : expression_content; 
+  sugar    : Ast_sugar.expression option;
+  location : Location.t
+  }
 
 and expression_content =
   (* Base *)

src/stages/common/types.ml

@@ -52,7 +52,6 @@ end
 module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
   open PARAMETER
 
-  type michelson_annotation = string
 
   type type_content =
     | T_sum of ctor_content constructor_map

src/stages/ligo_interpreter/PP.ml

@@ -34,7 +34,7 @@ let rec pp_value : value -> string = function
 let pp_env : env -> unit = fun env ->
   let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in
   let () = Env.iter (fun var v ->
-    Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v))
+    Format.printf "\t%a -> %s\n" Var.pp var (pp_value v))
   env in
   let () = Format.printf "\n}\n" in
   ()

src/stages/typesystem/misc.ml

@@ -96,9 +96,9 @@ module Substitution = struct
       | Ast_core.T_constant constant ->
          ok @@ Ast_core.T_constant constant
 
-    and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {type_content;location;type_meta} ->
+    and s_abstr_type_expression : (Ast_core.type_expression,_) w = fun ~substs {content;sugar;location} ->
-      let%bind type_content = s_abstr_type_content ~substs type_content in
+      let%bind content = s_abstr_type_content ~substs content in
-      ok @@ Ast_core.{type_content;location;type_meta}
+      ok @@ (Ast_core.{content;sugar;location} : Ast_core.type_expression)
 
     and s_type_expression : (T.type_expression,_) w = fun ~substs { type_content; location; type_meta } ->
       let%bind type_content = s_type_content ~substs type_content in

src/test/coase_tests.ml

@@ -221,10 +221,10 @@ let sell () =
     in
     let make_expecter : int -> Ast_core.expression -> (unit,_) result = fun n result ->
       let%bind (ops , storage) = trace_option (test_internal __LOC__) @@
-        Ast_core.get_e_pair result.expression_content in
+        Ast_core.get_e_pair result.content in
       let%bind () =
         let%bind lst = trace_option (test_internal __LOC__) @@
-          Ast_core.get_e_list ops.expression_content in
+          Ast_core.get_e_list ops.content in
           Assert.assert_list_size (test_internal __LOC__) lst 1 in
       let expected_storage =
         let cards = List.hds @@ cards_ez first_owner n in

src/test/contracts/expected/FA1.2.ligo.expected

@@ -31,10 +31,8 @@ type getBalance is
 type getTotalSupply is record [callback : contract (nat)]
 
 type action is
-    Transfer of transfer
+    Transfer of transfer | Approve of approve
-  | Approve of approve
+  | GetAllowance of getAllowance | GetBalance of getBalance
-  | GetAllowance of getAllowance
-  | GetBalance of getBalance
   | GetTotalSupply of getTotalSupply
 
 function transfer (const p : transfer; const s : storage)

src/test/contracts/expected/FA1.2.mligo.expected

@@ -24,10 +24,8 @@ type getBalance = {owner : address; callback : nat contract}
 type getTotalSupply = {callback : nat contract}
 
 type action =
-  Transfer of transfer
+  Transfer of transfer | Approve of approve
-| Approve of approve
+| GetAllowance of getAllowance | GetBalance of getBalance
-| GetAllowance of getAllowance
-| GetBalance of getBalance
 | GetTotalSupply of getTotalSupply
 
 let transfer (p, s : transfer * storage)
@@ -42,19 +40,19 @@ let transfer (p, s : transfer * storage)
                 s.allowances
         with
           Some value -> value
-        | None -> 0n
+        | None -> 0n in
-      in if (authorized_value < p.value)
+      if (authorized_value < p.value)
       then (failwith "Not Enough Allowance" : allowances)
       else
         Big_map.update
           (Tezos.sender, p.address_from)
           (Some (abs (authorized_value - p.value)))
-             s.allowances
+          s.allowances in
-  in let sender_balance =
+  let sender_balance =
     match Big_map.find_opt p.address_from s.tokens with
       Some value -> value
-       | None -> 0n
+    | None -> 0n in
-     in if (sender_balance < p.value)
+  if (sender_balance < p.value)
   then
     (failwith "Not Enough Balance"
      : operation list * storage)
@@ -63,21 +61,19 @@ let transfer (p, s : transfer * storage)
       Big_map.update
         p.address_from
         (Some (abs (sender_balance - p.value)))
-              s.tokens
+        s.tokens in
-          in let receiver_balance =
+    let receiver_balance =
-               match Big_map.find_opt p.address_to s.tokens
+      match Big_map.find_opt p.address_to s.tokens with
-               with
         Some value -> value
-               | None -> 0n
+      | None -> 0n in
-             in let new_tokens =
+    let new_tokens =
       Big_map.update
         p.address_to
         (Some (receiver_balance + p.value))
-                    new_tokens
+        new_tokens in
-                in ([] : operation list),
+    ([] : operation list),
     {s with
-                     tokens = new_tokens;
+      tokens = new_tokens; allowances = new_allowances}
-                     allowances = new_allowances}
 
 let approve (p, s : approve * storage)
 : operation list * storage =
@@ -87,8 +83,8 @@ let approve (p, s : approve * storage)
             s.allowances
     with
       Some value -> value
-    | None -> 0n
+    | None -> 0n in
-  in if previous_value > 0n && p.value > 0n
+  if previous_value > 0n && p.value > 0n
   then
     (failwith "Unsafe Allowance Change"
      : operation list * storage)
@@ -97,8 +93,8 @@ let approve (p, s : approve * storage)
       Big_map.update
         (p.spender, Tezos.sender)
         (Some (p.value))
-           s.allowances
+        s.allowances in
-       in ([] : operation list),
+    ([] : operation list),
     {s with
       allowances = new_allowances}
 
@@ -108,24 +104,24 @@ let getAllowance (p, s : getAllowance * storage)
     match Big_map.find_opt (p.owner, p.spender) s.allowances
     with
       Some value -> value
-    | None -> 0n
+    | None -> 0n in
-  in let op = Tezos.transaction value 0mutez p.callback
+  let op = Tezos.transaction value 0mutez p.callback in
-     in ([op], s)
+  ([op], s)
 
 let getBalance (p, s : getBalance * storage)
 : operation list * storage =
   let value =
     match Big_map.find_opt p.owner s.tokens with
       Some value -> value
-    | None -> 0n
+    | None -> 0n in
-  in let op = Tezos.transaction value 0mutez p.callback
+  let op = Tezos.transaction value 0mutez p.callback in
-     in ([op], s)
+  ([op], s)
 
 let getTotalSupply (p, s : getTotalSupply * storage)
 : operation list * storage =
-  let total = s.total_amount
+  let total = s.total_amount in
-  in let op = Tezos.transaction total 0mutez p.callback
+  let op = Tezos.transaction total 0mutez p.callback in
-     in ([op], s)
+  ([op], s)
 
 let main (a, s : action * storage) =
   match a with

src/test/contracts/expected/address.mligo.expected

@@ -1,3 +1,3 @@
 let main (p : key_hash) =
-  let c : unit contract = Tezos.implicit_account p
+  let c : unit contract = Tezos.implicit_account p in
-  in Tezos.address c
+  Tezos.address c

src/test/contracts/expected/amount_lambda.mligo.expected

@@ -1,6 +1,6 @@
 let f1 (x : unit) : unit -> tez =
-  let amt : tez = Current.amount
+  let amt : tez = Current.amount in
-  in fun (x : unit) -> amt
+  fun (x : unit) -> amt
 
 let f2 (x : unit) : unit -> tez =
   fun (x : unit) -> Current.amount

src/test/contracts/expected/assert.mligo.expected

@@ -1,3 +1,3 @@
 let main (p, s : bool * unit) =
-  let u : unit = assert p
+  let u : unit = assert p in
-  in ([] : operation list), s
+  ([] : operation list), s

src/test/contracts/expected/attributes.mligo.expected

@@ -1,8 +1,8 @@
 let x = 1 [@@inline]
 
 let foo (a : int) : int =
-  (let test = 2 + a [@@inline]
+  (let test = 2 + a [@@inline] in
-   in test) [@@inline]
+   test) [@@inline]
 
 let y = 1 [@@inline][@@other]
 
@@ -10,5 +10,5 @@ let bar (b : int) : int =
   let test = fun (z : int) -> 2 + b + z
     [@@inline]
     [@@foo]
-    [@@bar]
+    [@@bar] in
-  in test b
+  test b

src/test/contracts/expected/big_map.mligo.expected

@@ -18,5 +18,5 @@ let map1 : foo = Big_map.literal [(23, 0); (42, 0)]
 let map1 : foo = Big_map.literal [(23, 0); (42, 0)]
 
 let mutimaps (m : foo) (n : foo) : foo =
-  let bar : foo = Big_map.update 42 (Some 0) m
+  let bar : foo = Big_map.update 42 (Some 0) m in
-  in Big_map.update 42 (get bar) n
+  Big_map.update 42 (get bar) n

src/test/contracts/expected/bytes_unpack.mligo.expected

@@ -1,11 +1,11 @@
 let id_string (p : string) : string option =
-  let packed : bytes = Bytes.pack p
+  let packed : bytes = Bytes.pack p in
-  in (Bytes.unpack packed : string option)
+  (Bytes.unpack packed : string option)
 
 let id_int (p : int) : int option =
-  let packed : bytes = Bytes.pack p
+  let packed : bytes = Bytes.pack p in
-  in (Bytes.unpack packed : int option)
+  (Bytes.unpack packed : int option)
 
 let id_address (p : address) : address option =
-  let packed : bytes = Bytes.pack p
+  let packed : bytes = Bytes.pack p in
-  in (Bytes.unpack packed : address option)
+  (Bytes.unpack packed : address option)

src/test/contracts/expected/closure.mligo.expected

@@ -1,5 +1,5 @@
 let test (k : int) : int =
-  let j : int = k + 5
+  let j : int = k + 5 in
-  in let close : int -> int = fun (i : int) -> i + j
+  let close : int -> int = fun (i : int) -> i + j in
-     in let j : int = 20
+  let j : int = 20 in
-        in close 20
+  close 20

src/test/contracts/expected/condition-shadowing.mligo.expected

@@ -1,9 +1,9 @@
 let main (i : int) =
-  let result = 0
+  let result = 0 in
-  in if i = 2
+  if i = 2
   then
-       let result = 42
+    let result = 42 in
-       in result
+    result
   else
-       let result = 0
+    let result = 0 in
-       in result
+    result

src/test/contracts/expected/create_contract.mligo.expected

@@ -7,5 +7,5 @@ let main (action, store : string * string) : return =
          (([] : operation list), "one"))
       (None : key_hash option)
       300000000mutez
-      "un"
+      "un" in
-  in ([toto.0], store)
+  ([toto.0], store)

src/test/contracts/expected/double_michelson_or.mligo.expected

@@ -5,6 +5,6 @@ type foobar = (int, "baz", int, "fooo") michelson_or
 type return = operation list * storage
 
 let main (action, store : unit * storage) : return =
-  let foo = (M_right ("one") : storage)
+  let foo = (M_right ("one") : storage) in
-  in let bar = (M_right 1 : foobar)
+  let bar = (M_right 1 : foobar) in
-     in (([] : operation list), (foo : storage))
+  (([] : operation list), (foo : storage))

src/test/contracts/expected/fibo.mligo.expected

@@ -9,5 +9,5 @@ let main (p, store : unit * storage)
        f (y, x))
       (fun (x : int) (y : int) -> x + y)
       0
-      1
+      1 in
-  in ([] : operation list), store
+  ([] : operation list), store

src/test/contracts/expected/fibo2.mligo.expected

@@ -6,5 +6,5 @@ let main (p, store : unit * storage)
     (fun (f : int -> int) (z : int) (y : int) -> f y)
       (fun (x : int) -> x)
       0
-      1
+      1 in
-  in ([] : operation list), store
+  ([] : operation list), store

src/test/contracts/expected/fibo3.mligo.expected

@@ -8,5 +8,5 @@ let main (p, s : unit * storage) : operation list * storage =
        f y (x + y))
       (fun (x : int) (y : int) -> x + y)
       0
-      1
+      1 in
-  in ([] : operation list), store
+  ([] : operation list), store

src/test/contracts/expected/guess_string.mligo.expected

@@ -10,8 +10,8 @@ let attempt (p, store : param * storage) : return =
            : unit contract option)
     with
       Some contract -> contract
-    | None -> (failwith "No contract" : unit contract)
+    | None -> (failwith "No contract" : unit contract) in
-  in let transfer : operation =
+  let transfer : operation =
-       Tezos.transaction (unit, contract, 10000000mutez)
+    Tezos.transaction (unit, contract, 10000000mutez) in
-     in let store : storage = {challenge = p.new_challenge}
+  let store : storage = {challenge = p.new_challenge} in
-        in ([] : operation list), store
+  ([] : operation list), store

src/test/contracts/expected/id.ligo.expected

@@ -23,10 +23,8 @@ type update_details is
   ]
 
 type action is
-    Buy of buy
+    Buy of buy | Update_owner of update_owner
-  | Update_owner of update_owner
+  | Update_details of update_details | Skip of unit
-  | Update_details of update_details
-  | Skip of unit
 
 type storage is
   record [

src/test/contracts/expected/multisig-v2.ligo.expected

@@ -34,8 +34,7 @@ type default_pt is unit
 type return is list (operation) * storage
 
 type parameter is
-    Send of send_pt
+    Send of send_pt | Withdraw of withdraw_pt
-  | Withdraw of withdraw_pt
   | Default of default_pt
 
 function send (const param : send_pt; const s : storage)

src/test/contracts/expected/time-lock.ligo.expected

@@ -9,8 +9,7 @@ type call_pt is message_t
 type contract_return_t is list (operation) * storage_t
 
 type entry_point_t is
-    Call of call_pt
+    Call of call_pt | Default of default_pt
-  | Default of default_pt
 
 function call (const p : call_pt; const s : storage_t)
   : contract_return_t is

src/test/integration_tests.ml

@@ -2096,9 +2096,9 @@ let get_contract_ligo () : (unit, _) result =
   let%bind () =
     let make_input = fun _n -> e_unit () in
     let make_expected : int -> Ast_core.expression -> (unit, _) result = fun _n result ->
-      let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.expression_content in
+      let%bind (ops , storage) = trace_option (test_internal __LOC__) @@ Ast_core.get_e_pair result.content in
       let%bind () =
-        let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.expression_content in
+        let%bind lst = trace_option (test_internal __LOC__) @@ Ast_core.get_e_list ops.content in
         Assert.assert_list_size (test_internal __LOC__) lst 1 in
       let expected_storage = Ast_core.e_unit () in
       trace_option (test_internal __LOC__) @@ Ast_core.Misc.assert_value_eq (expected_storage , storage)

src/test/test_helpers.ml

@@ -112,7 +112,7 @@ let run_typed_program_with_imperative_input ?options
     (input: Ast_imperative.expression) : (Ast_core.expression, _) result =
   let%bind michelson_program = typed_program_with_imperative_input_to_michelson (program , state) entry_point input in
   let%bind michelson_output  = Ligo.Run.Of_michelson.run_no_failwith ?options michelson_program.expr michelson_program.expr_ty in
-  let%bind res =  Uncompile.uncompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in
+  let%bind res =  Decompile.Of_michelson.decompile_typed_program_entry_function_result program entry_point (Runned_result.Success michelson_output) in
   match res with
   | Runned_result.Success exp -> ok exp
   | Runned_result.Fail _ -> fail test_not_expected_to_fail
@@ -155,7 +155,7 @@ let expect_evaluate (program, _state) entry_point expecter =
   let%bind (exp,_)         = trace_option unknown @@ Mini_c.get_entry mini_c entry_point in
   let%bind michelson_value = Ligo.Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
   let%bind res_michelson   = Ligo.Run.Of_michelson.run_no_failwith michelson_value.expr michelson_value.expr_ty in
-  let%bind res             = Uncompile.uncompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in
+  let%bind res             = Decompile.Of_michelson.decompile_typed_program_entry_expression_result program entry_point (Success res_michelson) in
   let%bind res' = match res with
   | Runned_result.Success exp -> ok exp
   | Runned_result.Fail _ -> fail test_not_expected_to_fail in

src/test/time_lock_repeat_tests.ml

@@ -54,7 +54,7 @@ let early_call () =
   expect_string_failwith ~options (program, state) "main"
     (e_pair (e_unit ())  init_storage) exp_failwith
 
-let fake_uncompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]"
+let fake_decompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]"
 
 (* Test that when we use the contract the next use time advances by correct interval *)
 let interval_advance () =
@@ -64,7 +64,7 @@ let interval_advance () =
   let init_storage = storage lock_time 86400 empty_message in
   (* It takes a second for Tezos.now to be called, awful hack *)
   let%bind new_timestamp = mk_time "2000-01-02T10:10:11Z" in
-  let new_storage_fake = storage new_timestamp 86400 fake_uncompiled_empty_message in
+  let new_storage_fake = storage new_timestamp 86400 fake_decompiled_empty_message in
   let options =
     Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in
   expect_eq ~options (program, state) "main"

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

@@ -345,6 +345,10 @@ let trace_assert_fail_option error = function
    [let%bind lst' = bind_map_list f lst].  Same thing with folds.
  *)
 
+let bind_compose f g x = 
+  let%bind y = g x in
+  f y
+
 let bind_map_option f = function
     None -> ok None
 | Some s -> f s >>? fun x -> ok (Some x)

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

@@ -216,5 +216,6 @@ module Ne = struct
     match f hd with
     | Some x -> Some x
     | None -> find_map f tl
+  let append : 'a t -> 'a t -> 'a t = fun (hd, tl) (hd', tl') -> hd, List.append tl @@ hd' :: tl'
 
 end