diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml index f1437f44f..b8a6cd90e 100644 --- a/src/bin/expect_tests/michelson_converter.ml +++ b/src/bin/expect_tests/michelson_converter.ml @@ -202,4 +202,121 @@ let%expect_test _ = IF_LEFT { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } ; + DIP { DROP 2 } } } |}] + +let%expect_test _ = + run_ligo_good [ "compile-contract" ; (contract "double_fold_converter.religo") ; "main" ] ; + [%expect {| + { parameter + (list (pair (address %from_) + (list %txs (pair (address %to_) (pair (nat %token_id) (nat %amount)))))) ; + storage (big_map nat address) ; + code { DUP ; + CDR ; + DIG 1 ; + DUP ; + DUG 2 ; + CAR ; + ITER { SWAP ; + PAIR ; + DUP ; + CDR ; + DUP ; + CAR ; + SENDER ; + DIG 1 ; + DUP ; + DUG 2 ; + COMPARE ; + NEQ ; + IF { PUSH string "NOT_OWNER" ; FAILWITH } { PUSH unit Unit } ; + DIG 1 ; + DUP ; + DUG 2 ; + DIG 4 ; + DUP ; + DUG 5 ; + CAR ; + PAIR ; + DIG 3 ; + DUP ; + DUG 4 ; + CDR ; + ITER { SWAP ; + PAIR ; + DUP ; + CAR ; + DIG 1 ; + DUP ; + DUG 2 ; + CDR ; + DIG 1 ; + DUP ; + DUG 2 ; + CAR ; + DIG 2 ; + DUP ; + DUG 3 ; + CDR ; + DIG 2 ; + DUP ; + DUG 3 ; + CDR ; + CAR ; + DIG 3 ; + DUP ; + DUG 4 ; + CAR ; + DIG 4 ; + DUP ; + DUG 5 ; + CDR ; + CDR ; + PAIR ; + PAIR ; + DIG 2 ; + DUP ; + DUG 3 ; + DIG 1 ; + DUP ; + DUG 2 ; + CDR ; + GET ; + IF_NONE + { PUSH string "TOKEN_UNDEFINED" ; FAILWITH } + { DIG 2 ; + DUP ; + DUG 3 ; + DIG 1 ; + DUP ; + DUG 2 ; + COMPARE ; + EQ ; + IF { DUP } { PUSH string "INSUFFICIENT_BALANCE" ; FAILWITH } ; + DIP { DROP } } ; + DIG 2 ; + DUP ; + DUG 3 ; + DIG 4 ; + DUP ; + DUG 5 ; + DIG 3 ; + DUP ; + DUG 4 ; + CAR ; + CDR ; + SOME ; + DIG 4 ; + DUP ; + DUG 5 ; + CDR ; + UPDATE ; + PAIR ; + DIP { DROP 7 } } ; + DUP ; + CAR ; + DIP { DROP 5 } } ; + DUP ; + NIL operation ; + PAIR ; DIP { DROP 2 } } } |}] \ No newline at end of file diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 9c1973f0d..756c984d3 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -42,14 +42,6 @@ them. please report this to the developers." in ] in error ~data title content - let unsupported_iterator location = - let title () = "unsupported iterator" in - let content () = "only lambda are supported as iterators" in - let data = [ - row_loc location ; - ] in - error ~data title content - let not_functional_main location = let title () = "not functional main" in let content () = "main should be a function" in @@ -511,28 +503,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return @@ E_record_update (record, path, update) | E_constant {cons_name=name; arguments=lst} -> ( let iterator_generator iterator_name = - let lambda_to_iterator_body (f : AST.expression) (l : AST.lambda) = - let%bind body' = transpile_annotated_expression l.result in - let%bind (input , _) = AST.get_t_function f.type_expression in - let%bind input' = transpile_type input in - ok ((l.binder , input') , body') - in let expression_to_iterator_body (f : AST.expression) = - match f.expression_content with - | E_lambda l -> lambda_to_iterator_body f l - | E_variable v -> ( - let%bind elt = - trace_option (corner_case ~loc:__LOC__ "missing var") @@ - AST.Environment.get_opt v f.environment in - match elt.definition with - | ED_declaration { expr = f ; free_variables = _ } -> ( - match f.expression_content with - | E_lambda l -> lambda_to_iterator_body f l - | _ -> fail @@ unsupported_iterator f.location - ) - | _ -> fail @@ unsupported_iterator f.location - ) - | _ -> fail @@ unsupported_iterator f.location + let%bind (input , output) = AST.get_t_function f.type_expression in + let%bind f' = transpile_annotated_expression f in + let%bind input' = transpile_type input in + let%bind output' = transpile_type output in + let binder = Var.fresh ~name:"iterated" () in + let application = Mini_c.Combinators.e_application f' output' (Mini_c.Combinators.e_var binder input') in + ok ((binder , input'), application) in fun (lst : AST.expression list) -> match (lst , iterator_name) with | [f ; i] , C_ITER | [f ; i] , C_MAP -> ( diff --git a/src/passes/9-self_ast_typed/recompute_environment.ml b/src/passes/9-self_ast_typed/recompute_environment.ml index 4124038c2..bed098190 100644 --- a/src/passes/9-self_ast_typed/recompute_environment.ml +++ b/src/passes/9-self_ast_typed/recompute_environment.ml @@ -34,9 +34,9 @@ let rec expression : environment -> expression -> expression = fun env expr -> return @@ E_lambda { c with result } ) | E_let_in c -> ( - let env' = Environment.add_ez_declaration c.let_binder c.rhs env in - let let_result = self ~env' c.let_result in let rhs = self c.rhs in + let env' = Environment.add_ez_declaration c.let_binder rhs env in + let let_result = self ~env' c.let_result in return @@ E_let_in { c with rhs ; let_result } ) (* rec fun_name binder -> result *) @@ -152,7 +152,7 @@ let program : environment -> program -> program = fun init_env prog -> let aux (pre_env , rev_decls) decl_wrapped = let (Declaration_constant c) = Location.unwrap decl_wrapped in let expr = expression pre_env c.expr in - let post_env = Environment.add_ez_declaration c.binder c.expr pre_env in + let post_env = Environment.add_ez_declaration c.binder expr pre_env in let post_env' = merge c.post_env post_env in let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in let decl_wrapped' = { decl_wrapped with wrap_content } in diff --git a/src/stages/5-mini_c/combinators.ml b/src/stages/5-mini_c/combinators.ml index ff421421c..f01eda745 100644 --- a/src/stages/5-mini_c/combinators.ml +++ b/src/stages/5-mini_c/combinators.ml @@ -183,6 +183,15 @@ let e_let_in ?loc v tv inline expr body : expression = Expression.(make_tpl ?loc E_let_in ((v , tv) , inline, expr , body) , get_type body )) +let e_application ?loc f t arg: expression = Expression.(make_tpl ?loc( + E_application (f,arg) , + t + )) +let e_var ?loc vname t: expression = Expression.(make_tpl ?loc( + E_variable vname , + t + )) + let ez_e_sequence ?loc a b : expression = Expression.(make_tpl (E_sequence (make_tpl ?loc (a , t_unit ()) , b) , get_type b)) diff --git a/src/stages/5-mini_c/combinators.mli b/src/stages/5-mini_c/combinators.mli index f198e8b8e..3a9aab3ed 100644 --- a/src/stages/5-mini_c/combinators.mli +++ b/src/stages/5-mini_c/combinators.mli @@ -78,3 +78,5 @@ val d_unit : value val environment_wrap : environment -> environment -> environment_wrap val id_environment_wrap : environment -> environment_wrap +val e_var : ?loc:Location.t -> var_name -> type_expression -> expression +val e_application : ?loc:Location.t -> expression -> type_expression -> expression -> expression diff --git a/src/test/contracts/double_fold_converter.religo b/src/test/contracts/double_fold_converter.religo new file mode 100644 index 000000000..01245222b --- /dev/null +++ b/src/test/contracts/double_fold_converter.religo @@ -0,0 +1,72 @@ +type tokenId = nat; +type tokenOwner = address; +type tokenAmount = nat; +type transferContents = { + to_: tokenOwner, + token_id: tokenId, + amount: tokenAmount +}; +type transfer = { + from_: tokenOwner, + txs: list(transferContents) +}; +type transferContentsMichelson = michelson_pair_right_comb(transferContents); +type transferAuxiliary = { + from_: tokenOwner, + txs: list(transferContentsMichelson) +}; +type transferMichelson = michelson_pair_right_comb(transferAuxiliary); +type transferParameter = list(transferMichelson); +type parameter = +| Transfer(transferParameter) +type storage = big_map(tokenId, tokenOwner); +type entrypointParameter = (parameter, storage); +type entrypointReturn = (list(operation), storage); +let errorTokenUndefined = "TOKEN_UNDEFINED"; +let errorNotOwner = "NOT_OWNER"; +let errorInsufficientBalance = "INSUFFICIENT_BALANCE"; +type transferContentsIteratorAccumulator = (storage, tokenOwner); +let transferContentsIterator = ((accumulator, transferContentsMichelson): (transferContentsIteratorAccumulator, transferContentsMichelson)): transferContentsIteratorAccumulator => { + let (storage, from_) = accumulator; + let transferContents: transferContents = Layout.convert_from_right_comb(transferContentsMichelson); + let tokenOwner: option(tokenOwner) = Map.find_opt(transferContents.token_id, storage); + let tokenOwner = switch (tokenOwner) { + | None => (failwith(errorTokenUndefined): tokenOwner) + | Some(tokenOwner) => if (tokenOwner == from_) { + tokenOwner + } else { + (failwith(errorInsufficientBalance): tokenOwner); + } + }; + let storage = Map.update( + transferContents.token_id, + Some(transferContents.to_), + storage + ); + (storage, from_) +}; +let allowOnlyOwnTransfer = (from: tokenOwner): unit => { + if (from != Tezos.sender) { + failwith(errorNotOwner) + } else { (); } +} +let transferIterator = ((storage, transferMichelson): (storage, transferMichelson)): storage => { + let transferAuxiliary2: transferAuxiliary = Layout.convert_from_right_comb(transferMichelson); + let from_: tokenOwner = transferAuxiliary2.from_; + allowOnlyOwnTransfer(from_); + let (storage, _) = List.fold( + transferContentsIterator, + transferAuxiliary2.txs, + (storage, from_) + ); + storage +}; +let transfer = ((transferParameter, storage): (transferParameter, storage)): entrypointReturn => { + let storage = List.fold(transferIterator, transferParameter, storage); + (([]: list(operation)), storage); +}; +let main = ((parameter, storage): entrypointParameter): entrypointReturn => { + switch (parameter) { + | Transfer(transferParameter) => transfer((transferParameter, storage)) + } +} \ No newline at end of file