From dfcccff7481c0fb60337ce4a71bcd632eb7862c7 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 17 Apr 2020 13:36:33 +0200 Subject: [PATCH] generating good code --- src/passes/01-parser/cameligo/AST.ml | 4 +--- src/passes/01-parser/cameligo/Parser.mly | 8 +++---- src/passes/01-parser/cameligo/ParserLog.ml | 14 ++++------- src/passes/01-parser/pascaligo/AST.ml | 4 +--- src/passes/01-parser/pascaligo/Parser.mly | 8 +++---- src/passes/01-parser/pascaligo/ParserLog.ml | 14 ++++------- src/passes/01-parser/reasonligo/Parser.mly | 8 +++---- .../02-concrete_to_imperative/cameligo.ml | 5 ++-- .../02-concrete_to_imperative/pascaligo.ml | 5 ++-- .../imperative_to_sugar.ml | 12 +++++----- src/passes/06-sugar_to_core/sugar_to_core.ml | 12 +++++----- src/passes/08-typer-new/typer.ml | 8 +++---- src/passes/08-typer-new/untyper.ml | 6 ++--- src/passes/08-typer-old/typer.ml | 16 +++++++------ src/passes/10-transpiler/transpiler.ml | 4 +++- src/passes/12-compiler/compiler_program.ml | 5 ++-- src/stages/1-ast_imperative/PP.ml | 4 ++-- src/stages/1-ast_imperative/combinators.ml | 2 +- src/stages/1-ast_imperative/combinators.mli | 2 +- src/stages/1-ast_imperative/types.ml | 3 +-- src/stages/2-ast_sugar/PP.ml | 4 ++-- src/stages/2-ast_sugar/combinators.ml | 2 +- src/stages/2-ast_sugar/combinators.mli | 2 +- src/stages/2-ast_sugar/types.ml | 3 +-- src/stages/3-ast_core/PP.ml | 4 ++-- src/stages/3-ast_core/combinators.ml | 7 +++++- src/stages/3-ast_core/combinators.mli | 3 ++- src/stages/3-ast_core/types.ml | 3 +-- src/stages/4-ast_typed/PP.ml | 4 ++-- src/stages/4-ast_typed/combinators.ml | 10 ++++++++ src/stages/4-ast_typed/combinators.mli | 2 ++ src/stages/5-mini_c/PP.ml | 24 +++++++++---------- src/stages/5-mini_c/PP.mli | 2 +- src/stages/5-mini_c/types.ml | 2 +- src/stages/typesystem/misc.ml | 6 ++--- src/test/contracts/michelson_insertion.mligo | 2 +- 36 files changed, 109 insertions(+), 115 deletions(-) diff --git a/src/passes/01-parser/cameligo/AST.ml b/src/passes/01-parser/cameligo/AST.ml index 56321474d..d55788bd2 100644 --- a/src/passes/01-parser/cameligo/AST.ml +++ b/src/passes/01-parser/cameligo/AST.ml @@ -402,9 +402,7 @@ and cond_expr = { and code_insert = { language : string reg; - code : string reg; - colon : colon; - type_anno : type_expr; + code : expr; rbracket : rbracket; } (* Projecting regions from some nodes of the AST *) diff --git a/src/passes/01-parser/cameligo/Parser.mly b/src/passes/01-parser/cameligo/Parser.mly index d645ac39f..9e1471a2d 100644 --- a/src/passes/01-parser/cameligo/Parser.mly +++ b/src/passes/01-parser/cameligo/Parser.mly @@ -709,12 +709,10 @@ seq_expr: disj_expr_level | if_then_else (seq_expr) { $1 } code_insert: - Insert "" ":" type_expr "]" { - let region = cover $1.region $5 in + Insert expr "]" { + let region = cover $1.region $3 in let value = { language =$1; code =$2; - colon =$3; - type_anno=$4; - rbracket =$5} + rbracket =$3} in {region; value} } diff --git a/src/passes/01-parser/cameligo/ParserLog.ml b/src/passes/01-parser/cameligo/ParserLog.ml index 7ba9cf096..579ba3b22 100644 --- a/src/passes/01-parser/cameligo/ParserLog.ml +++ b/src/passes/01-parser/cameligo/ParserLog.ml @@ -520,11 +520,9 @@ and print_record_expr state e = print_ne_injection state print_field_assign e and print_code_insert state {value; _} = - let {language;code;colon;type_anno;rbracket} : code_insert = value in + let {language;code;rbracket} : code_insert = value in print_string state language; - print_string state code; - print_token state colon ":"; - print_type_expr state type_anno; + print_expr state code; print_token state rbracket "]" and print_field_assign state {value; _} = @@ -901,12 +899,8 @@ and pp_code_insert state (rc : code_insert) = let () = let state = state#pad 3 1 in pp_node state ""; - pp_string (state#pad 1 0) rc.code in - let () = - let state = state#pad 3 2 in - pp_node state ""; - pp_type_expr (state#pad 1 0) rc.type_anno - in () + pp_expr (state#pad 1 0) rc.code in + () and pp_let_in state node = let {binding; body; attributes; kwd_rec; _} = node in diff --git a/src/passes/01-parser/pascaligo/AST.ml b/src/passes/01-parser/pascaligo/AST.ml index 4adfb7b45..83a509f52 100644 --- a/src/passes/01-parser/pascaligo/AST.ml +++ b/src/passes/01-parser/pascaligo/AST.ml @@ -439,9 +439,7 @@ and for_collect = { and code_insert = { language : string reg; - code : string reg; - colon : colon; - type_anno : type_expr; + code : expr; rbracket : rbracket; } diff --git a/src/passes/01-parser/pascaligo/Parser.mly b/src/passes/01-parser/pascaligo/Parser.mly index 1548ae30b..d89ca566b 100644 --- a/src/passes/01-parser/pascaligo/Parser.mly +++ b/src/passes/01-parser/pascaligo/Parser.mly @@ -975,14 +975,12 @@ update_record: in {region; value} } code_insert_expr: - Insert "" ":" type_expr "]" { - let region = cover $1.region $5 in + Insert expr "]" { + let region = cover $1.region $3 in let value = { language =$1; code =$2; - colon =$3; - type_anno=$4; - rbracket =$5} + rbracket =$3} in {region; value} } field_assignment: diff --git a/src/passes/01-parser/pascaligo/ParserLog.ml b/src/passes/01-parser/pascaligo/ParserLog.ml index 41f8405d1..de77a5bb0 100644 --- a/src/passes/01-parser/pascaligo/ParserLog.ml +++ b/src/passes/01-parser/pascaligo/ParserLog.ml @@ -231,11 +231,9 @@ and print_fun_expr state {value; _} = print_expr state return and print_code_insert state {value; _} = - let {language;code;colon;type_anno;rbracket} : code_insert = value in + let {language;code;rbracket} : code_insert = value in print_string state language; - print_string state code; - print_token state colon ":"; - print_type_expr state type_anno; + print_expr state code; print_token state rbracket "]" and print_parameters state {value; _} = @@ -1027,12 +1025,8 @@ and pp_code_insert state (rc : code_insert) = let () = let state = state#pad 3 1 in pp_node state ""; - pp_string (state#pad 1 0) rc.code in - let () = - let state = state#pad 3 2 in - pp_node state ""; - pp_type_expr (state#pad 1 0) rc.type_anno - in () + pp_expr (state#pad 1 0) rc.code in + () and pp_parameters state {value; _} = let params = Utils.nsepseq_to_list value.inside in diff --git a/src/passes/01-parser/reasonligo/Parser.mly b/src/passes/01-parser/reasonligo/Parser.mly index 208e251dc..630a4ec8a 100644 --- a/src/passes/01-parser/reasonligo/Parser.mly +++ b/src/passes/01-parser/reasonligo/Parser.mly @@ -921,14 +921,12 @@ update_record: in {region; value} } code_insert: - Insert "" ":" type_expr "]" { - let region = cover $1.region $5 in + Insert expr "]" { + let region = cover $1.region $3 in let value = { language =$1; code =$2; - colon =$3; - type_anno=$4; - rbracket =$5} + rbracket =$3} in {region; value} } expr_with_let_expr: diff --git a/src/passes/02-concrete_to_imperative/cameligo.ml b/src/passes/02-concrete_to_imperative/cameligo.ml index 3a6d44145..ed32b2c27 100644 --- a/src/passes/02-concrete_to_imperative/cameligo.ml +++ b/src/passes/02-concrete_to_imperative/cameligo.ml @@ -641,9 +641,8 @@ in trace (abstracting_expr t) @@ | ECodeInsert ci -> ( let (ci, loc) = r_split ci in let language = ci.language.value in - let code = ci.code.value in - let%bind type_anno = compile_type_expression ci.type_anno in - return @@ e_raw_code ~loc language code type_anno + let%bind code = compile_expression ci.code in + return @@ e_raw_code ~loc language code ) and compile_fun lamb' : expr result = diff --git a/src/passes/02-concrete_to_imperative/pascaligo.ml b/src/passes/02-concrete_to_imperative/pascaligo.ml index a7a459135..0f999db18 100644 --- a/src/passes/02-concrete_to_imperative/pascaligo.ml +++ b/src/passes/02-concrete_to_imperative/pascaligo.ml @@ -462,9 +462,8 @@ let rec compile_expression (t:Raw.expr) : expr result = | ECodeInsert ci -> let (ci, loc) = r_split ci in let language = ci.language.value in - let code = ci.code.value in - let%bind type_anno = compile_type_expression ci.type_anno in - return @@ e_raw_code ~loc language code type_anno + let%bind code = compile_expression ci.code in + return @@ e_raw_code ~loc language code and compile_update (u: Raw.update Region.reg) = let u, loc = r_split u in diff --git a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml index 5e2aa0a4d..d495e87ee 100644 --- a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml @@ -218,9 +218,9 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression) let%bind rhs = compile_expression rhs in let%bind let_result = compile_expression let_result in return @@ O.e_let_in ~loc (binder,ty_opt) false inline rhs let_result - | I.E_raw_code {language;code;type_anno} -> - let%bind type_anno = compile_type_expression type_anno in - return @@ O.e_raw_code ~loc language code type_anno + | I.E_raw_code {language;code} -> + let%bind code = compile_expression code in + return @@ O.e_raw_code ~loc language code | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.e_constructor ~loc constructor element @@ -616,9 +616,9 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind rhs = uncompile_expression rhs in let%bind let_result = uncompile_expression let_result in return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} - | O.E_raw_code {language;code;type_anno} -> - let%bind type_anno = uncompile_type_expression type_anno in - return @@ I.E_raw_code {language;code;type_anno} + | O.E_raw_code {language;code} -> + let%bind code = uncompile_expression' code in + return @@ I.E_raw_code {language;code} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} diff --git a/src/passes/06-sugar_to_core/sugar_to_core.ml b/src/passes/06-sugar_to_core/sugar_to_core.ml index 17049b9d7..67f1f3072 100644 --- a/src/passes/06-sugar_to_core/sugar_to_core.ml +++ b/src/passes/06-sugar_to_core/sugar_to_core.ml @@ -71,9 +71,9 @@ let rec compile_expression : I.expression -> O.expression result = let%bind rhs = compile_expression rhs in let%bind let_result = compile_expression let_result in return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} - | I.E_raw_code {language;code;type_anno} -> - let%bind type_anno = compile_type_expression type_anno in - return @@ O.E_raw_code {language;code;type_anno} + | I.E_raw_code {language;code} -> + let%bind code = compile_expression code in + return @@ O.E_raw_code {language;code} | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.E_constructor {constructor;element} @@ -331,9 +331,9 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind rhs = uncompile_expression rhs in let%bind let_result = uncompile_expression let_result in return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} - | O.E_raw_code {language;code;type_anno} -> - let%bind type_anno = uncompile_type_expression type_anno in - return @@ I.E_raw_code {language;code;type_anno} + | O.E_raw_code {language;code} -> + let%bind code = uncompile_expression code in + return @@ I.E_raw_code {language;code} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} diff --git a/src/passes/08-typer-new/typer.ml b/src/passes/08-typer-new/typer.ml index c9f7964b6..b45087f07 100644 --- a/src/passes/08-typer-new/typer.ml +++ b/src/passes/08-typer-new/typer.ml @@ -332,10 +332,10 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression let wrapped = Wrap.let_in rhs.type_expression rhs_tv_opt let_result.type_expression in return_wrapped (E_let_in {let_binder; rhs; let_result; inline}) state'' wrapped - | E_raw_code {language ; code; type_anno} -> - let%bind type_anno = evaluate_type e type_anno in - let wrapped = Wrap.raw_code type_anno in - return_wrapped (E_raw_code {language; code ;type_anno}) state wrapped + | E_raw_code {language ; code} -> + let%bind (code,state') = type_expression e state code in + let wrapped = Wrap.raw_code code.type_expression in + return_wrapped (E_raw_code {language; code}) state' wrapped | E_ascription {anno_expr;type_annotation} -> let%bind tv = evaluate_type e type_annotation in let%bind (expr' , state') = type_expression e state anno_expr in diff --git a/src/passes/08-typer-new/untyper.ml b/src/passes/08-typer-new/untyper.ml index eec12e376..00bbdcb2d 100644 --- a/src/passes/08-typer-new/untyper.ml +++ b/src/passes/08-typer-new/untyper.ml @@ -282,9 +282,9 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind rhs = untype_expression rhs in let%bind result = untype_expression let_result in return (e_let_in (let_binder , (Some tv)) inline rhs result) - | E_raw_code {language; code; type_anno} -> - let%bind type_anno = untype_type_expression type_anno in - return @@ e_raw_code language code type_anno + | E_raw_code {language; code} -> + let%bind code = untype_expression code in + return @@ e_raw_code language code | E_recursive {fun_name; fun_type; lambda} -> let%bind lambda = untype_lambda fun_type lambda in let%bind fun_type = untype_type_expression fun_type in diff --git a/src/passes/08-typer-old/typer.ml b/src/passes/08-typer-old/typer.ml index 43c2e8091..732bfa601 100644 --- a/src/passes/08-typer-old/typer.ml +++ b/src/passes/08-typer-old/typer.ml @@ -936,10 +936,12 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let e' = Environment.add_ez_declaration (let_binder) rhs e in let%bind let_result = type_expression' e' let_result in return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression - | E_raw_code {language;code;type_anno} -> - let%bind type_anno = evaluate_type e type_anno in - let%bind (_input_type,_output_type) = get_t_function type_anno in - return (E_raw_code {language;code;type_anno}) type_anno + | E_raw_code {language;code} -> + let%bind (code,type_expression) = I.get_e_ascription code.expression_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 + return (E_raw_code {language;code}) code.type_expression | E_recursive {fun_name; fun_type; lambda} -> let%bind fun_type = evaluate_type e fun_type in let e' = Environment.add_ez_binder fun_name fun_type e in @@ -1076,9 +1078,9 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind rhs = untype_expression rhs in let%bind result = untype_expression let_result in return (e_let_in (let_binder , (Some tv)) inline rhs result) - | E_raw_code {language; code; type_anno} -> - let%bind type_anno = untype_type_expression type_anno in - return (e_raw_code language code type_anno) + | E_raw_code {language; code} -> + let%bind code = untype_expression code in + return (e_raw_code language code) | 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 diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index d335b6914..36c0c5ec7 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -616,12 +616,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = aux expr' tree'' ) ) - | E_raw_code { language; code; type_anno} -> + | E_raw_code { language; code} -> let backend = "Michelson" in let%bind () = trace_strong (language_backend_mismatch language backend ae.location) @@ Assert.assert_true (String.equal language backend) in + let type_anno = get_type_expression code in let%bind type_anno' = transpile_type type_anno in + let%bind code = get_a_verbatim code in return @@ E_raw_michelson (code, type_anno') and transpile_lambda l (input_type , output_type) = diff --git a/src/passes/12-compiler/compiler_program.ml b/src/passes/12-compiler/compiler_program.ml index b3630bccb..8c7168231 100644 --- a/src/passes/12-compiler/compiler_program.ml +++ b/src/passes/12-compiler/compiler_program.ml @@ -486,9 +486,8 @@ and translate_expression (expr:expression) (env:environment) : michelson result | E_raw_michelson (code, type_anno) -> let (code, _e) = Michelson_parser.V1.parse_expression ~check:false code in let code = Tezos_micheline.Micheline.root code.expanded in - let annot = Format.asprintf "(%a)" Mini_c.PP.type_value type_anno in - - return @@ Michelson.prim ~children:[code] ~annot:[annot] I_PUSH + let%bind ty = Compiler_type.type_ type_anno in + return @@ i_push ty code and translate_function_body ({body ; binder} : anon_function) lst input : michelson result = let pre_env = Environment.of_list lst in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 4da6c425e..2853dd37e 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -113,8 +113,8 @@ and expression_content ppf (ec : expression_content) = expression_content (E_lambda lambda) | E_let_in { let_binder ; rhs ; let_result; inline } -> fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result - | E_raw_code {language; code; type_anno} -> - fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno + | E_raw_code {language; code} -> + fprintf ppf "[%%%s %a]" language expression code | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 1431b73c2..22687dd67 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -115,7 +115,7 @@ let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b} let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ 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_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_raw_code ?loc language code type_anno = make_e ?loc @@ E_raw_code {language; code; type_anno} +let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 1aabf637f..c9ce85c03 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -95,7 +95,7 @@ val e_application : ?loc:Location.t -> expression -> expression -> expression val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression -val e_raw_code : ?loc:Location.t -> string -> string -> type_expression -> expression +val e_raw_code : ?loc:Location.t -> string -> expression -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 9c72139f3..4d4766f1f 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -103,8 +103,7 @@ and let_in = and raw_code = { language : string ; - code : string ; - type_anno : type_expression ; + code : expression ; } and constructor = {constructor: constructor'; element: expression} diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 4299d83f0..99cf01d3f 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -112,8 +112,8 @@ and expression_content ppf (ec : expression_content) = expression rhs option_inline inline expression let_result - | E_raw_code {language; code; type_anno} -> - fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno + | E_raw_code {language; code} -> + fprintf ppf "[%%%s %a]" language expression code | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation | E_cond {condition; then_clause; else_clause} -> diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 71296491a..8c254df2b 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -103,8 +103,8 @@ let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b} let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ 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_let_in ?loc (binder, ascr) mut inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut } +let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code} -let e_raw_code ?loc language code type_anno: expression = make_e ?loc @@ E_raw_code { language; code; type_anno} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = s; element = a} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index a41f594fb..7d4fcbcdf 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -70,7 +70,6 @@ val e_some : ?loc:Location.t -> expression -> expression val e_none : ?loc:Location.t -> unit -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression -val e_raw_code : ?loc:Location.t -> string -> string -> type_expression -> expression val e_constructor : ?loc:Location.t -> constructor' -> expression -> expression val e_constant : ?loc:Location.t -> constant' -> expression list -> expression @@ -78,6 +77,7 @@ val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option val e_application : ?loc:Location.t -> expression -> expression -> expression val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression +val e_raw_code : ?loc:Location.t -> string -> expression -> expression val e_record : ?loc:Location.t -> expr label_map -> expression val e_accessor : ?loc:Location.t -> expression -> access list -> expression diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 8ef30cab5..0e525288a 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -101,8 +101,7 @@ and let_in = { and raw_code = { language : string ; - code : string ; - type_anno : type_expression ; + code : expression ; } and constructor = {constructor: constructor'; element: expression} diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index c06cb8760..4f36e6801 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -48,8 +48,8 @@ and expression_content ppf (ec : expression_content) = cases | E_let_in { let_binder ;rhs ; let_result; inline } -> fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" option_type_name let_binder expression rhs option_inline inline expression let_result - | E_raw_code {language; code; type_anno} -> - fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno + | E_raw_code {language; code} -> + fprintf ppf "[%%%s %a]" language expression code | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index 53961eefc..139a9ece8 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -102,7 +102,7 @@ let e_application ?loc a b = make_e ?loc @@ 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_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ 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_raw_code ?loc language code type_anno = make_e ?loc @@ E_raw_code {language; code; type_anno} +let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} @@ -164,6 +164,11 @@ let get_e_tuple = fun t -> | E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" +let get_e_ascription = fun a -> + match a with + | E_ascription {anno_expr; type_annotation} -> ok @@ (anno_expr,type_annotation) + | _ -> simple_fail "ast_core: get_e_ascription: not an ascription" + (* Same as get_e_pair *) let extract_pair : expression -> (expression * expression) result = fun e -> match e.expression_content with diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index 52907c025..2eae3795b 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -77,7 +77,7 @@ val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_record_accessor : ?loc:Location.t -> expression -> label -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression -val e_raw_code : ?loc:Location.t -> string -> string -> type_expression -> expression +val e_raw_code : ?loc:Location.t -> string -> expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression val e_constant : ?loc:Location.t -> constant' -> expression list -> expression @@ -101,6 +101,7 @@ val get_e_pair : expression_content -> ( expression * expression ) result val get_e_list : expression_content -> ( expression list ) result val get_e_tuple : expression_content -> ( expression list ) result +val get_e_ascription : expression_content -> ( expression * type_expression ) result (* val get_e_failwith : expression -> expression result val is_e_failwith : expression -> bool diff --git a/src/stages/3-ast_core/types.ml b/src/stages/3-ast_core/types.ml index 11c5775be..43ba9c5c8 100644 --- a/src/stages/3-ast_core/types.ml +++ b/src/stages/3-ast_core/types.ml @@ -74,8 +74,7 @@ and let_in = and raw_code = { language : string ; - code : string ; - type_anno : type_expression ; + code : expression ; } and constructor = {constructor: constructor'; element: expression} diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index b9616b4eb..605b44be5 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -291,8 +291,8 @@ and expression_content ppf (ec: expression_content) = | E_let_in {let_binder; rhs; let_result; inline} -> fprintf ppf "let %a = %a%a in %a" expression_variable let_binder expression rhs option_inline inline expression let_result - | E_raw_code {language; code; type_anno} -> - fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno + | E_raw_code {language; code} -> + fprintf ppf "[%%%s %a]" language expression code | E_recursive { fun_name;fun_type; lambda} -> fprintf ppf "rec (%a:%a => %a )" expression_variable fun_name diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index b423da73d..6b33a9f3e 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -360,6 +360,16 @@ let get_a_int (t:expression) = | E_literal (Literal_int n) -> ok n | _ -> simple_fail "not an int" +let get_a_string (t:expression) = + match t.expression_content with + | E_literal (Literal_string s) -> ok @@ Ligo_string.extract s + | _ -> simple_fail "not a string" + +let get_a_verbatim (t:expression) = + match t.expression_content with + E_literal (Literal_string (Verbatim v)) -> ok @@ v + | _ -> simple_fail "not a verbatim string" + let get_a_unit (t:expression) = match t.expression_content with | E_literal (Literal_unit) -> ok () diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index f4fe615b2..4033d4e25 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -152,6 +152,8 @@ val ez_e_a_record : ( label * expression ) list -> expression val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression val get_a_int : expression -> Z.t result +val get_a_string : expression -> string result +val get_a_verbatim : expression -> string result val get_a_unit : expression -> unit result val get_a_bool : expression -> bool result val get_a_record_accessor : expression -> (expression * label) result diff --git a/src/stages/5-mini_c/PP.ml b/src/stages/5-mini_c/PP.ml index e9aa005f9..15d40f6f5 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -70,20 +70,20 @@ let rec value ppf : value -> unit = function | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst | D_set lst -> fprintf ppf "Set[%a]" (list_sep_d value) lst -and type_value_annotated ppf : type_value annotated -> unit = fun (_, tv) -> - type_value ppf tv +and type_expression_annotated ppf : type_expression annotated -> unit = fun (_, tv) -> + type_expression ppf tv -and type_value ppf : type_value -> unit = function - | T_pair (a,b) -> fprintf ppf "pair %a %a" type_value_annotated a type_value_annotated b - | T_or (a,b) -> fprintf ppf "or %a %a" type_value_annotated a type_value_annotated b - | T_function (a, b) -> fprintf ppf "lambda (%a) %a" type_value a type_value b +and type_expression ppf : type_expression -> unit = fun te -> match te.type_content with + | T_pair (a,b) -> fprintf ppf "pair %a %a" type_expression_annotated a type_expression_annotated b + | T_or (a,b) -> fprintf ppf "or %a %a" type_expression_annotated a type_expression_annotated b + | T_function (a, b) -> fprintf ppf "lambda (%a) %a" type_expression a type_expression b | T_base tc -> fprintf ppf "%a" type_constant tc - | T_map (k,v) -> fprintf ppf "Map (%a,%a)" type_value k type_value v - | T_big_map (k,v) -> fprintf ppf "BigMap (%a,%a)" type_value k type_value v - | T_list e -> fprintf ppf "List (%a)" type_value e - | T_set e -> fprintf ppf "Set (%a)" type_value e - | T_contract c -> fprintf ppf "Contract (%a)" type_value c - | T_option c -> fprintf ppf "Option (%a)" type_value c + | T_map (k,v) -> fprintf ppf "Map (%a,%a)" type_expression k type_expression v + | T_big_map (k,v) -> fprintf ppf "BigMap (%a,%a)" type_expression k type_expression v + | T_list e -> fprintf ppf "List (%a)" type_expression e + | T_set e -> fprintf ppf "Set (%a)" type_expression e + | T_contract c -> fprintf ppf "Contract (%a)" type_expression c + | T_option c -> fprintf ppf "Option (%a)" type_expression c and value_assoc ppf : (value * value) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" value a value b diff --git a/src/stages/5-mini_c/PP.mli b/src/stages/5-mini_c/PP.mli index d4510b271..c036a5b07 100644 --- a/src/stages/5-mini_c/PP.mli +++ b/src/stages/5-mini_c/PP.mli @@ -12,7 +12,7 @@ val type_variable : formatter -> type_expression -> unit val environment_element : formatter -> environment_element -> unit val environment : formatter -> environment -> unit val value : formatter -> value -> unit -val type_value : formatter -> type_value -> unit +val type_expression : formatter -> type_expression -> unit (* val value_assoc : formatter -> (value * value) -> unit diff --git a/src/stages/5-mini_c/types.ml b/src/stages/5-mini_c/types.ml index a3a5b22bf..db6f7c4f3 100644 --- a/src/stages/5-mini_c/types.ml +++ b/src/stages/5-mini_c/types.ml @@ -91,7 +91,7 @@ and expression_content = | E_sequence of (expression * expression) | E_record_update of (expression * [`Left | `Right] list * expression) | E_while of (expression * expression) - | E_raw_michelson of (string * type_value) + | E_raw_michelson of (string * type_expression) and expression = { content : expression_content ; diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index a697b28d3..076a47484 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -159,9 +159,9 @@ module Substitution = struct let%bind rhs = s_expression ~substs rhs in let%bind let_result = s_expression ~substs let_result in ok @@ T.E_let_in { let_binder; rhs; let_result; inline } - | T.E_raw_code {language; code; type_anno} -> - let%bind type_anno = s_type_expression ~substs type_anno in - ok @@ T.E_raw_code {language; code; type_anno} + | T.E_raw_code {language; code} -> + let%bind code = s_expression ~substs code in + ok @@ T.E_raw_code {language; code} | T.E_recursive { fun_name; fun_type; lambda} -> let%bind fun_name = s_variable ~substs fun_name in let%bind fun_type = s_type_expression ~substs fun_type in diff --git a/src/test/contracts/michelson_insertion.mligo b/src/test/contracts/michelson_insertion.mligo index 17ee7a64f..b43b6d06a 100644 --- a/src/test/contracts/michelson_insertion.mligo +++ b/src/test/contracts/michelson_insertion.mligo @@ -1,5 +1,5 @@ // Test michelson insertion in CameLIGO let michelson_add (n : nat) : nat = - let f : nat -> nat = [%Michelson {| DUP;ADD |}] in + let f : nat -> nat = [%Michelson ({| DUP;ADD |} : nat -> nat) ] in f n