diff --git a/dexter.ligo b/dexter.ligo new file mode 100644 index 000000000..0af2bb11d --- /dev/null +++ b/dexter.ligo @@ -0,0 +1,585 @@ +// Dexter +// a decentralized Tezos exchange for XTZ and FA1.2 +// copyright: camlCase 2019-2020 +// version: 0.1.5.0 + +// ============================================================================= +// Entrypoints +// ============================================================================= + +type entrypoint is +| Approve of (address * nat * nat) +| AddLiquidity of (address * nat * nat * timestamp) +| RemoveLiquidity of (address * address * nat * tez * nat * timestamp) +| XtzToToken of (address * nat * timestamp) +| TokenToXtz of (address * address * nat * tez * timestamp) +| BetForBakingRights of (key_hash * address * nat) +| EndAuctionRound +| UpdateTokenBalance of (nat) + +// the transfer entrypoint of the FA1.2 contract +type token_contract_transfer is (address * address * nat); + +// ============================================================================= +// Storage +// ============================================================================= + +type baker_address is key_hash; + +type account is record + balance : nat; + allowances: map(address, nat); +end + +// this is just to force big_maps as the first item of a pair on the top +// so we can still use the old big map route without big map id for +// convenience +type s is record + current_baker: option(baker_address); + current_baker_candidate: option(baker_address * address * tez * nat); + last_auction: timestamp; + lqt_total: nat; + token_address: address; + token_balance: nat; + rewards: (tez * nat); +end + +type storage is record + s: s; + accounts: big_map(address, account); +end + +// ============================================================================= +// Constants +// ============================================================================= + +const empty_allowances : map(address,nat) = map end; + +const empty_ops : list(operation) = list end; + +const no_baker_candidate: option(baker_address * address * tez * nat) = None; + +const no_baker: option(key_hash) = None; + +// 21 days +// 86400 seconds * 21 +const dexter_cycle: int = 1814400; + +// ============================================================================= +// Helper Functions +// ============================================================================= + +function mutez_to_natural(const a: tez): nat is + block {skip} with a / 1mutez + +function natural_to_mutez(const a: nat): tez is + block {skip} with a * 1mutez + +// this will fail if provided a negative number +function int_to_nat(const error: string ; const a: int): nat is + block { + var result : nat := 0n; + if (a >= 0) then block { + result := abs(a); + } else block { + failwith(error) + }; + } with result; + +// get an account from the big_map, if one does not exist for a particular +// address then create one. +function get_account(const a: address ; const m: big_map(address, account)): account is + block { skip } with ( + case (m[a]) of + | None -> record balance = 0n; allowances = empty_allowances; end + | Some(account) -> account + end + ); + +function update_allowance(const owner : address; + const spender : address; + const updated_allowance: nat; + var storage : storage): + storage is + block { + if (spender =/= owner) then block { + var account: account := get_account(owner, storage.accounts); + account.allowances[spender] := updated_allowance; + storage.accounts[owner] := record balance = account.balance; allowances = account.allowances; end; + } else { + skip; + } + } with storage; + +// if sender is owner, return amount, otherwise check if sender has permission +// if true then return amount, otherwise fail +function get_sender_allowance(const owner: address ; const storage: storage): nat is + block { + var result: nat := 0n; + case storage.accounts[owner] of + | None -> failwith("2") + | Some(account) -> block { + if sender =/= owner then block { + case account.allowances[sender] of + | None -> failwith("3") + | Some(allowance) -> result := allowance + end; + } else block { + result := account.balance + } + } + end; + } with result; + +function get_current_candidate_bet (const storage: storage): (tez * nat) is + block { + var current_candidate_bet: (tez * nat) := (0mutez, 0n); + case (storage.s.current_baker_candidate) of + | None -> skip + | Some(current_baker_candidate) -> current_candidate_bet := (current_baker_candidate.2, current_baker_candidate.3) + end + } with current_candidate_bet; + +// there might be some zero division edge cases +function get_xtz_pool (const current_candidate_bet_xtz: tez ; const storage: storage): (tez) is + block { + const time_since_last_auction: int = now - storage.s.last_auction; + const days_since_last_auction: int = time_since_last_auction / 86400; + var xtz_pool : tez := 0mutez; + + if (days_since_last_auction < dexter_cycle) then block { + const released_rewards : tez = (storage.s.rewards.0 / abs((days_since_last_auction * 1000 / dexter_cycle))) / 1000n; + const unreleased_rewards: tez = storage.s.rewards.0 - released_rewards; + + xtz_pool := balance - current_candidate_bet_xtz - unreleased_rewards - amount; + } else block { + // the slow reward wait has passed, all the rewards are released + + xtz_pool := balance - current_candidate_bet_xtz - amount; + }; + } with xtz_pool; + +// there might be some zero division edge cases +function get_token_pool (const current_candidate_bet_token: nat ; const storage: storage): (nat) is + block { + const time_since_last_auction: int = now - storage.s.last_auction; + const days_since_last_auction: int = time_since_last_auction / 86400; + var token_pool : nat := 0n; + + if (days_since_last_auction < dexter_cycle) then block { + const reward_days : int = days_since_last_auction; + const released_rewards : nat = (storage.s.rewards.1 / abs((reward_days * 1000 / dexter_cycle))) / 1000n; + const unreleased_rewards: nat = abs(storage.s.rewards.1 - released_rewards); + + token_pool := abs(storage.s.token_balance - current_candidate_bet_token - unreleased_rewards); + } else block { + // the slow reward wait has passed, all the rewards are released + token_pool := abs(storage.s.token_balance - current_candidate_bet_token) + }; + } with token_pool; + +// ============================================================================= +// Entrypoint Functions +// ============================================================================= + +function approve(const spender : address; + const allowance: nat; + const current_allowance: nat; + var storage : storage): + (list(operation) * storage) is + block { + if (spender =/= sender) then block { + // get the sender's account + // if the account does not exist, fail, we do not want to create accounts here + // creating accounts should be done in add_liquidity + const account: account = get_account(sender, storage.accounts); + + var sender_allowances: map(address, nat) := account.allowances; + sender_allowances[spender] := allowance; + storage.accounts[sender] := record balance = account.balance; allowances = sender_allowances; end; + } else block { + failwith("1"); + } + } with (empty_ops, storage); + +// it is assumed that the exchange contract has permission from the FA1.2 token +// to manage the assets of the user. It is the responsibility of the dApp +// developer to handle permissions. +function add_liquidity(const owner : address; + const min_lqt_created : nat; + const max_tokens_deposited: nat; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + // add_liquidity performs a transfer to the token contract, we need to + // return the operations + var op_list: list(operation) := nil; + + if (now < deadline) then skip else block { + failwith("4"); + }; + + if (max_tokens_deposited > 0n) then skip else block { + failwith("5"); + }; + + if (amount > 0mutez) then skip else block { + failwith("6"); + }; + + if (storage.s.lqt_total > 0n) then block { + // lqt_total greater than zero + // use the existing exchange rate + + if (min_lqt_created > 0n) then skip else block { + failwith("7"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const nat_amount : nat = mutez_to_natural(amount); + const tokens_deposited : nat = nat_amount * token_pool / xtz_pool; + const lqt_minted : nat = nat_amount * storage.s.lqt_total / xtz_pool; + + if (max_tokens_deposited >= tokens_deposited) then skip else block { + failwith("8"); + }; + + if (lqt_minted >= min_lqt_created) then skip else block { + failwith("9"); + }; + + const account: account = get_account(owner, storage.accounts); + const new_balance: nat = account.balance + lqt_minted; + storage.accounts[owner] := record balance = new_balance; allowances = account.allowances; end; + storage.s.lqt_total := storage.s.lqt_total + lqt_minted; + storage.s.token_balance := storage.s.token_balance + tokens_deposited; + + // send FA1.2 from owner to exchange + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op1: operation = transaction((owner, self_address, tokens_deposited), 0mutez, token_contract); + op_list := list op1; end; + + } else block { + // initial add liquidity + if (amount >= 1tz) then skip else block { + failwith("10"); + }; + + const tokens_deposited : nat = max_tokens_deposited; + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const initial_liquidity : nat = mutez_to_natural(balance - current_candidate_bet.0); + + storage.s.lqt_total := initial_liquidity; + storage.accounts[owner] := record balance = initial_liquidity; allowances = empty_allowances; end; + storage.s.token_balance := tokens_deposited; + + // send FA1.2 tokens from owner to exchange + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op1: operation = transaction((owner, self_address, tokens_deposited), 0mutez, token_contract); + op_list := list op1; end; + } + } with (op_list, storage); + +function remove_liquidity(const owner : address; + const to_ : address; + const lqt_burned : nat; + const min_xtz_withdrawn : tez; + const min_tokens_withdrawn : nat; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (now < deadline) then skip else block { + failwith("11"); + }; + + if (min_xtz_withdrawn > 0mutez) then skip else block { + failwith("12"); + }; + + if (min_tokens_withdrawn > 0n) then skip else block { + failwith("13"); + }; + + if (lqt_burned > 0n) then skip else block { + failwith("14"); + }; + + // returns total if sender is owner, otherwise looks it up + const lqt: nat = get_sender_allowance(owner, storage); + + if (lqt >= lqt_burned) then skip else block { + failwith("15"); + }; + + if (storage.s.lqt_total > 0n) then skip else block { + failwith("16"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_withdrawn : tez = natural_to_mutez(lqt_burned * mutez_to_natural(balance - current_candidate_bet.0) / storage.s.lqt_total); + + if (xtz_withdrawn >= min_xtz_withdrawn) then skip else block { + failwith("17"); + }; + + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const tokens_withdrawn: nat = lqt_burned * token_pool / storage.s.lqt_total; + + if (tokens_withdrawn >= min_tokens_withdrawn) then skip else block { + failwith("18"); + }; + + const account: account = get_account(owner, storage.accounts); + + if (account.balance >= lqt_burned) then skip else block { + failwith("19"); + }; + + const new_balance: nat = int_to_nat("33", account.balance - lqt_burned); + storage.accounts[owner] := record balance = new_balance; allowances = account.allowances; end; + + storage.s.lqt_total := int_to_nat("34", storage.s.lqt_total - lqt_burned); + storage.s.token_balance := int_to_nat("35", storage.s.token_balance - tokens_withdrawn); + + // update allowance + // lqt - lqt_burned is safe, we have already checed that lqt >= lqt_burned + storage := update_allowance(owner, sender, int_to_nat("36", lqt - lqt_burned), storage); + + // send xtz_withdrawn to to_ address + const to_contract: contract(unit) = get_contract(to_); + const op1: operation = transaction(unit, xtz_withdrawn, to_contract); + + // send tokens_withdrawn to to address + // if tokens_withdrawn if greater than storage.s.token_balance, this will fail + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op2: operation = transaction((self_address, to_, tokens_withdrawn), 0mutez, token_contract); + op_list := list op1; op2; end + } with (op_list, storage); + +function xtz_to_token(const to_ : address; + const min_tokens_bought: nat; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (now < deadline) then skip else block { + failwith("20"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); + const nat_amount : nat = mutez_to_natural(amount); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const tokens_bought : nat = (nat_amount * 997n * token_pool) / (xtz_pool * 1000n + (nat_amount * 997n)); + + if (tokens_bought >= min_tokens_bought) then skip else block { + failwith("21"); + }; + + storage.s.token_balance := int_to_nat("32", storage.s.token_balance - tokens_bought); + + // send tokens_withdrawn to to address + // if tokens_bought is greater than storage.s.token_balance, this will fail + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op: operation = transaction((self_address, to_, tokens_bought), 0mutez, token_contract); + + // append internal operations + op_list := list op; end; + } with (op_list, storage); + +function token_to_xtz(const owner : address; // the address of the owner of FA1.2 + const to_ : address; + const tokens_sold : nat; + const min_xtz_bought: tez; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (now < deadline) then skip else block { + failwith("22"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_pool : tez = get_xtz_pool(current_candidate_bet.0, storage); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const xtz_bought : tez = natural_to_mutez((tokens_sold * 997n * mutez_to_natural(xtz_pool)) / (token_pool * 1000n + (tokens_sold * 997n))); + + if (xtz_bought >= min_xtz_bought) then skip else block { + failwith("23"); + }; + + storage.s.token_balance := storage.s.token_balance + tokens_sold; + + // send xtz_bought to to_ address + const to_contract: contract(unit) = get_contract(to_); + const op1: operation = transaction(unit, xtz_bought, to_contract); + + // send tokens_sold to the exchange address + // this assumes that the exchange has an allowance for the token and owner in FA1.2 + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op2: operation = transaction((owner, self_address, tokens_sold), 0mutez, token_contract); + + // append internal operations + op_list := list op1; op2; end; + } with (op_list, storage); + +function assert_valid_baker (const current_baker: option(key_hash); + const candidate: key_hash): (operation * operation) is + block { + // test the candidate baker, if it is valid this will not fail + const test_set_delegate_operation: operation = set_delegate(Some(candidate)); + + // reset to the current baker + const reset_set_delegate_operation: operation = set_delegate(current_baker); + } with (test_set_delegate_operation, reset_set_delegate_operation); + +function bet_for_baking_rights (const candidate : key_hash; + const token_source : address; + const max_tokens_bet : nat; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + + // this is a trick to assert that the provided baker address is valid + case (storage.s.current_baker_candidate) of + | None -> block { + const op_pair: (operation * operation) = assert_valid_baker(storage.s.current_baker, candidate); + op_list := op_pair.0 # op_list; + op_list := op_pair.1 # op_list; + } + | Some(current_baker_candidate) -> block { + if (current_baker_candidate.0 = candidate) then skip else block { + const op_pair: (operation * operation) = assert_valid_baker(storage.s.current_baker, candidate); + op_list := op_pair.0 # op_list; + op_list := op_pair.1 # op_list; + }; + } + end; + + // now we are sure it is a valid baker + + // set a minimum bet + if (max_tokens_bet > 0n) then skip else block { + failwith("24"); + }; + + if (amount > 0mutez) then skip else block { + failwith("25"); + }; + + const current_candidate_bet : (tez * nat) = get_current_candidate_bet(storage); + + if (amount > current_candidate_bet.0) then skip else { failwith("26") }; + + const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const nat_amount : nat = mutez_to_natural(amount); + const tokens_deposited : nat = nat_amount * token_pool / xtz_pool; + + if (tokens_deposited > current_candidate_bet.1) then skip else { failwith("27") }; + if (tokens_deposited > max_tokens_bet) then skip else { failwith("28") }; + + case (storage.s.current_baker_candidate) of + | None -> block { + // add the tokens_deposited to the token_balance + storage.s.token_balance := storage.s.token_balance + tokens_deposited; + } + | Some(current_baker_candidate) -> block { + // return rejected candidates tez and tokens to previous candidate + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const return_token_op: operation = transaction((self_address, current_baker_candidate.1, current_baker_candidate.3), 0mutez, token_contract); + op_list := return_token_op # op_list; + + const to_contract: contract(unit) = get_contract(current_baker_candidate.1); + const return_xtz_op: operation = transaction(unit, current_baker_candidate.2, to_contract); + op_list := return_xtz_op # op_list; + + // remove the tokens from the current_baker_candidate + // add the tokens_deposited to the token_balance + storage.s.token_balance := abs(storage.s.token_balance - current_baker_candidate.3) + tokens_deposited; + } + end; + + storage.s.current_baker_candidate := Some((candidate,token_source,amount,tokens_deposited)); + + // send FA1.2 from owner to exchange, dexter needs permission to transfer these tokens + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const xtz_to_dexter_op: operation = transaction((token_source, self_address, tokens_deposited), 0mutez, token_contract); + op_list := xtz_to_dexter_op # op_list; + + } with (op_list, storage); + +function end_auction_round(var storage : storage) : (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + // 604800 seconds is one week + if (now > storage.s.last_auction + 604800) then skip else {failwith("29")}; + + case (storage.s.current_baker_candidate) of + | None -> block { + const set_delegate_op: operation = set_delegate(no_baker); + op_list := set_delegate_op # op_list; + } + | Some(current_baker_candidate) -> block { + case (storage.s.current_baker) of + | None -> block { + storage.s.current_baker := Some(current_baker_candidate.0); + storage.s.current_baker_candidate := no_baker_candidate; + storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; + storage.s.last_auction := now; + const set_delegate_op: operation = set_delegate(storage.s.current_baker); + op_list := set_delegate_op # op_list; + } + | Some(current_baker) -> block { + if (current_baker = current_baker_candidate.0) then block { + storage.s.current_baker_candidate := no_baker_candidate; + storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; + storage.s.last_auction := now; + } else { + storage.s.current_baker := Some(current_baker_candidate.0); + storage.s.current_baker_candidate := no_baker_candidate; + storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; + storage.s.last_auction := now; + const set_delegate_op: operation = set_delegate(storage.s.current_baker); + op_list := set_delegate_op # op_list; + } + } + end; + } + end; + + } with (op_list, storage); + +function update_token_balance(const token_balance: nat ; var storage : storage) : (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (sender =/= storage.s.token_address) then { + failwith("31"); + } else { + storage.s.token_balance := token_balance; + } + } with (op_list, storage); + +// ============================================================================= +// Main +// ============================================================================= + +function main (const entrypoint : entrypoint ; const storage : storage) : (list(operation) * storage) is + (case entrypoint of + | Approve(xs) -> approve(xs.0,xs.1,xs.2,storage) + | AddLiquidity(xs) -> add_liquidity(xs.0,xs.1,xs.2,xs.3,storage) + | RemoveLiquidity(xs) -> remove_liquidity(xs.0,xs.1,xs.2,xs.3,xs.4,xs.5,storage) + | XtzToToken(xs) -> xtz_to_token(xs.0,xs.1,xs.2,storage) + | TokenToXtz(xs) -> token_to_xtz(xs.0,xs.1,xs.2,xs.3,xs.4,storage) + | BetForBakingRights(xs) -> bet_for_baking_rights(xs.0,xs.1,xs.2,storage) + | EndAuctionRound -> end_auction_round(storage) + | UpdateTokenBalance(xs) -> update_token_balance(xs, storage) + end); diff --git a/gitlab-pages/docs/language-basics/maps-records.md b/gitlab-pages/docs/language-basics/maps-records.md index 1f49d318c..4139db6e9 100644 --- a/gitlab-pages/docs/language-basics/maps-records.md +++ b/gitlab-pages/docs/language-basics/maps-records.md @@ -230,6 +230,106 @@ xy_translate "({x:2,y:3,z:1}, {dx:3,dy:4})" You have to understand that `p` has not been changed by the functional update: a nameless new version of it has been created and returned. +#### Nested updates + +A unique feature of LIGO is the ability to perform nested updates on records. + +For example if you have the following record structure: + + + +```pascaligo +type color is +| Blue +| Green + +type preferences is record [ + color : color; + other : int; +] + +type account is record [ + id : int; + preferences : preferences; +] +``` + + + + +```cameligo +type color = + Blue +| Green + +type preferences = { + color : color; + other : int; +} + +type account = { + id: int; + preferences: preferences; +} +``` + + + + +```reasonligo +type color = + Blue +| Green; + +type preferences = { + color : color, + other : int +} + +type account = { + id : int, + preferences : preferences +} +``` + + + +You can update the nested record with the following code: + + + +```pascaligo + +function change_color_preference (const account : account; const color : color ) : account is + block { + account := account with record [preferences.color = color] + } with account + +``` + + + + +```cameligo +let change_color_preference (account : account) (color : color) : account = + { account with preferences.color = color } +``` + + + + +```reasonligo +let change_color_preference = (account : account, color : color): account => + { ...account, preferences.color: color }; +``` + + + +Note that all the records in the path will get updated. In this example that's +`account` and `preferences`. + + + ### Record Patches Another way to understand what it means to update a record value is to @@ -318,6 +418,8 @@ xy_translate "(record [x=2;y=3;z=1], record [dx=3;dy=4])" The hiding of a variable by another (here `p`) is called `shadowing`. + + ## Maps *Maps* are a data structure which associate values of the same type to diff --git a/gitlab-pages/docs/reference/current.md b/gitlab-pages/docs/reference/current.md index 56c719630..a08916711 100644 --- a/gitlab-pages/docs/reference/current.md +++ b/gitlab-pages/docs/reference/current.md @@ -21,13 +21,13 @@ type timestamp A date in the real world. -type mutez +type tez -type mutez +type tez -type mutez +type tez A specific type for tokens. @@ -83,13 +83,13 @@ type chain_id The identifier of a chain, used to indicate test or main chains. -function balance : mutez +function balance : tez -val balance : mutez +val balance : tez -let balance: mutez +let balance: tez Get the balance for the contract. @@ -263,13 +263,13 @@ let not_tomorrow: bool = (Tezos.now == in_24_hrs); -function amount : mutez +function amount : tez -val amount : mutez +val amount : tez -let amount: mutez +let amount: tez Get the amount of tez provided by the sender to complete this diff --git a/scripts/test_cli.sh b/scripts/test_cli.sh index 5bda10f9f..c41a4db8e 100755 --- a/scripts/test_cli.sh +++ b/scripts/test_cli.sh @@ -7,7 +7,7 @@ dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo m expected_compiled_parameter="(Right 1)"; expected_compiled_storage=1; -expected_dry_run_output="( list[] , 2 )"; +expected_dry_run_output="( LIST_EMPTY() , 2 )"; if [ "$compiled_storage" != "$expected_compiled_storage" ]; then echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead"; diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 984a0163b..3419ad93b 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -7,13 +7,13 @@ let bad_contract basename = let%expect_test _ = run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ; - [%expect {| 1870 bytes |}] ; + [%expect {| 1872 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ; - [%expect {| 1324 bytes |}] ; + [%expect {| 1294 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ; - [%expect {| 3231 bytes |}] ; + [%expect {| 2974 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ; [%expect {| 589 bytes |}] ; @@ -227,16 +227,17 @@ let%expect_test _ = NIL operation ; SWAP ; CONS ; - DIP { DIP 4 { DUP } ; - DIG 4 ; - DIP 4 { DUP } ; - DIG 4 ; + DUP ; + DIP { DIP 5 { DUP } ; + DIG 5 ; + DIP 5 { DUP } ; + DIG 5 ; DIP { DUP ; CDR ; SWAP ; CAR ; CAR } ; SWAP ; PAIR ; PAIR } ; PAIR ; - DIP { DROP 13 } } ; + DIP { DROP 14 } } ; DIP { DROP } } { DUP ; DIP { DIP { DUP } ; SWAP } ; @@ -312,11 +313,8 @@ let%expect_test _ = SWAP ; CAR ; CDR ; - DUP ; - DIP { DIP 2 { DUP } ; DIG 2 } ; - PAIR ; - DIP { DIP { DUP } ; SWAP } ; - PAIR ; + DIP { DUP } ; + SWAP ; DIP 3 { DUP } ; DIG 3 ; CAR ; @@ -333,31 +331,31 @@ let%expect_test _ = PAIR ; DUP ; CAR ; - CAR ; + CDR ; DIP { DUP } ; SWAP ; CAR ; - CDR ; + CAR ; DIP 2 { DUP } ; DIG 2 ; CDR ; - DIP 2 { DUP } ; - DIG 2 ; - DIP { DIP { DUP } ; SWAP } ; + DIP { DUP } ; + SWAP ; + DIP { DIP 2 { DUP } ; DIG 2 } ; PAIR ; - DIP 3 { DUP } ; - DIG 3 ; + DIP 2 { DUP } ; + DIG 2 ; IF_CONS - { DIP 4 { DUP } ; - DIG 4 ; + { DIP 5 { DUP } ; + DIG 5 ; DIP 4 { DUP } ; DIG 4 ; CAR ; DIP { DIP { DUP } ; SWAP ; HASH_KEY } ; COMPARE ; EQ ; - IF { DIP 5 { DUP } ; - DIG 5 ; + IF { DIP 6 { DUP } ; + DIG 6 ; DIP 2 { DUP } ; DIG 2 ; DIP { DIP 5 { DUP } ; @@ -371,8 +369,8 @@ let%expect_test _ = PAIR ; PACK } } ; CHECK_SIGNATURE ; - IF { DIP 6 { DUP } ; - DIG 6 ; + IF { DIP 7 { DUP } ; + DIG 7 ; PUSH nat 1 ; ADD ; DIP { DUP } ; @@ -407,9 +405,10 @@ let%expect_test _ = CAR ; DIP 2 { DUP } ; DIG 2 ; + CAR ; + SWAP ; CDR ; SWAP ; - CAR ; PAIR ; SWAP ; CDR ; @@ -421,10 +420,9 @@ let%expect_test _ = CAR ; DIP 3 { DUP } ; DIG 3 ; - CAR ; - SWAP ; CDR ; SWAP ; + CAR ; PAIR ; SWAP ; CDR ; @@ -460,16 +458,14 @@ let%expect_test _ = DIP { DROP 2 } } ; DIP 3 { DUP } ; DIG 3 ; - CAR ; DIP { DUP } ; - PAIR ; - DIP { DROP 3 } } ; - DUP ; - CAR ; - CAR ; + SWAP ; + DIP { DROP 4 } } ; + DIP 2 { DUP } ; + DIG 2 ; UNIT ; EXEC ; - DIP { DUP ; CDR } ; + DIP { DUP } ; PAIR ; DIP { DROP 7 } } } |} ] @@ -518,19 +514,19 @@ let%expect_test _ = GT ; IF { PUSH string "Message size exceed maximum limit" ; FAILWITH } { PUSH unit Unit } ; - DIP 4 { DUP } ; - DIG 4 ; EMPTY_SET address ; + DUP ; + DIP { DIP 5 { DUP } ; DIG 5 } ; PAIR ; - DIP 2 { DUP } ; - DIG 2 ; - DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR } ; + DIP 3 { DUP } ; + DIG 3 ; + DIP { DIP 6 { DUP } ; DIG 6 ; CAR ; CDR ; CDR } ; GET ; IF_NONE - { DIP 5 { DUP } ; - DIG 5 ; - DIP 6 { DUP } ; + { DIP 6 { DUP } ; DIG 6 ; + DIP 7 { DUP } ; + DIG 7 ; CDR ; CAR ; CAR ; @@ -540,7 +536,7 @@ let%expect_test _ = PUSH nat 1 ; ADD ; SOME ; - DIP { DIP 6 { DUP } ; DIG 6 ; CDR ; CAR ; CAR } ; + DIP { DIP 7 { DUP } ; DIG 7 ; CDR ; CAR ; CAR } ; SENDER ; UPDATE ; DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ; @@ -548,31 +544,33 @@ let%expect_test _ = PAIR ; SWAP ; PAIR ; - DIP { DUP } ; - SWAP ; - CAR ; - DIP { DUP } ; - PAIR ; EMPTY_SET address ; PUSH bool True ; SENDER ; UPDATE ; + DIP 2 { DUP } ; + DIG 2 ; + DIP 2 { DUP } ; + DIG 2 ; SWAP ; + CAR ; + PAIR ; CDR ; + DIP { DUP } ; SWAP ; PAIR ; - DIP { DROP } } - { DIP 6 { DUP } ; - DIG 6 ; + DIP { DROP 2 } } + { DIP 7 { DUP } ; + DIG 7 ; DIP { DUP } ; SWAP ; SENDER ; MEM ; IF { DUP } - { DIP 7 { DUP } ; - DIG 7 ; - DIP 8 { DUP } ; + { DIP 8 { DUP } ; DIG 8 ; + DIP 9 { DUP } ; + DIG 9 ; CDR ; CAR ; CAR ; @@ -582,7 +580,7 @@ let%expect_test _ = PUSH nat 1 ; ADD ; SOME ; - DIP { DIP 8 { DUP } ; DIG 8 ; CDR ; CAR ; CAR } ; + DIP { DIP 9 { DUP } ; DIG 9 ; CDR ; CAR ; CAR } ; SENDER ; UPDATE ; DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ; @@ -628,25 +626,21 @@ let%expect_test _ = GT ; IF { PUSH string "Maximum number of proposal reached" ; FAILWITH } { PUSH unit Unit } ; - DIP 8 { DUP } ; - DIG 8 ; + NIL operation ; + DUP ; DIP { DIP 3 { DUP } ; DIG 3 } ; PAIR ; - DIP { DIP 7 { DUP } ; DIG 7 ; NIL operation ; SWAP ; PAIR } ; - PAIR ; - DIP { DIP 2 { DUP } ; DIG 2 } ; - PAIR ; - DIP 4 { DUP } ; - DIG 4 ; + DIP 5 { DUP } ; + DIG 5 ; SIZE ; - DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CDR } ; + DIP { DIP 4 { DUP } ; DIG 4 ; CDR ; CDR } ; COMPARE ; GE ; - IF { DIP 3 { DUP } ; - DIG 3 ; - DIP 9 { DUP } ; - DIG 9 ; - DIP { DIP 4 { DUP } ; DIG 4 ; CAR ; CDR ; CDR ; NONE (set address) } ; + IF { DIP 4 { DUP } ; + DIG 4 ; + DIP 11 { DUP } ; + DIG 11 ; + DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR ; NONE (set address) } ; UPDATE ; DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ; SWAP ; @@ -658,7 +652,7 @@ let%expect_test _ = CDR ; CAR ; CDR ; - DIP { DIP 10 { DUP } ; DIG 10 } ; + DIP { DIP 12 { DUP } ; DIG 12 } ; EXEC ; DIP { DUP } ; SWAP ; @@ -667,7 +661,7 @@ let%expect_test _ = CDR ; CAR ; CDR ; - DIP { DIP 11 { DUP } ; DIG 11 } ; + DIP { DIP 13 { DUP } ; DIG 13 } ; CONCAT ; SHA256 ; DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CAR } ; @@ -689,32 +683,26 @@ let%expect_test _ = SWAP ; CDR ; CAR ; - DIP 2 { DUP } ; - DIG 2 ; - CDR ; - CDR ; DIP { DUP } ; SWAP ; DIP { DUP } ; - PAIR ; - DIP { DIP 2 { DUP } ; DIG 2 } ; - PAIR ; - DIP 2 { DUP } ; - DIG 2 ; + SWAP ; DIP { DIP 12 { DUP } ; DIG 12 } ; MEM ; - IF { DIP 3 { DUP } ; - DIG 3 ; - DIP 3 { DUP } ; - DIG 3 ; - DIP { DIP 2 { DUP } ; - DIG 2 ; + IF { DIP 2 { DUP } ; + DIG 2 ; + DIP 2 { DUP } ; + DIG 2 ; + DIP { DIP 4 { DUP } ; + DIG 4 ; + CDR ; + CDR ; PUSH nat 1 ; SWAP ; SUB ; ABS ; SOME ; - DIP { DIP 4 { DUP } ; DIG 4 ; CDR ; CAR ; CAR } } ; + DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CAR ; CAR } } ; UPDATE ; DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ; PAIR ; @@ -723,23 +711,21 @@ let%expect_test _ = PAIR ; DIP { DUP } ; SWAP ; - CAR ; DIP { DUP } ; - PAIR ; - DIP { DROP } } + SWAP ; + DIP { DROP 2 } } { DUP } ; + DIP 4 { DUP } ; + DIG 4 ; DIP 5 { DUP } ; DIG 5 ; - DIP 6 { DUP } ; - DIG 6 ; CAR ; DIP 2 { DUP } ; DIG 2 ; - CDR ; DIP { DROP ; CDR } ; PAIR ; CAR ; - DIP { DROP 6 } } ; + DIP { DROP 5 } } ; DIP 4 { DUP } ; DIG 4 ; DIP 4 { DUP } ; @@ -749,12 +735,10 @@ let%expect_test _ = PAIR ; DIP 3 { DUP } ; DIG 3 ; - DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ; SWAP ; - PAIR ; + CDR ; SWAP ; PAIR ; - PAIR ; DIP 2 { DUP } ; DIG 2 ; SWAP ; @@ -765,14 +749,14 @@ let%expect_test _ = PAIR ; DIP { DROP 4 } } { DUP ; - DIP 4 { DUP } ; - DIG 4 ; - DIP 10 { DUP } ; - DIG 10 ; - DIP { DIP 6 { DUP } ; - DIG 6 ; + DIP 5 { DUP } ; + DIG 5 ; + DIP 12 { DUP } ; + DIG 12 ; + DIP { DIP 7 { DUP } ; + DIG 7 ; SOME ; - DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR } } ; + DIP { DIP 6 { DUP } ; DIG 6 ; CAR ; CDR ; CDR } } ; UPDATE ; DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ; SWAP ; @@ -785,11 +769,9 @@ let%expect_test _ = PAIR } ; DUP ; CAR ; - CDR ; - CDR ; DIP { DUP ; CDR } ; PAIR ; - DIP { DROP 15 } } ; + DIP { DROP 17 } } ; DIP { DROP } } { DUP ; DIP { DIP { DUP } ; SWAP } ; @@ -800,9 +782,8 @@ let%expect_test _ = SWAP ; CAR ; PACK ; - DUP ; - DIP { DIP { DUP } ; SWAP } ; - PAIR ; + DIP { DUP } ; + SWAP ; DIP { DUP } ; SWAP ; DIP { DIP 2 { DUP } ; DIG 2 ; CAR ; CDR ; CDR } ; @@ -851,12 +832,7 @@ let%expect_test _ = DIP { DROP 2 } } { DUP } ; DUP ; - DIP 3 { DUP } ; - DIG 3 ; - DIP { DIP 6 { DUP } ; DIG 6 } ; - PAIR ; - DIP { DUP } ; - PAIR ; + DUP ; DIP 4 { DUP } ; DIG 4 ; SIZE ; @@ -878,10 +854,9 @@ let%expect_test _ = PAIR ; DIP { DUP } ; SWAP ; - CAR ; DIP { DUP } ; - PAIR ; - DIP { DROP } } + SWAP ; + DIP { DROP 2 } } { DUP ; DIP 2 { DUP } ; DIG 2 ; @@ -898,47 +873,15 @@ let%expect_test _ = SWAP ; PAIR ; PAIR ; - SWAP ; - CAR ; - PAIR } ; + DIP { DROP } } ; DIP 7 { DUP } ; DIG 7 ; DIP 3 { DUP } ; DIG 3 ; + DIP { DROP ; DUP } ; SWAP ; - CAR ; - PAIR ; - DIP { DUP } ; - SWAP ; - CAR ; - CDR ; - SWAP ; - CDR ; - SWAP ; - PAIR ; - DIP { DUP } ; - SWAP ; - CDR ; - SWAP ; - CAR ; - PAIR ; - DIP { DUP } ; - SWAP ; - CAR ; - CDR ; - SWAP ; - CDR ; - SWAP ; - PAIR ; - DIP { DUP } ; - SWAP ; - CDR ; - SWAP ; - CAR ; - PAIR ; - DIP { DROP 7 } } ; + DIP { DROP 8 } } ; DUP ; - CDR ; NIL operation ; PAIR ; DIP { DROP 6 } } ; @@ -1093,11 +1036,11 @@ let%expect_test _ = let%expect_test _ = run_ligo_good [ "dry-run" ; contract "redeclaration.ligo" ; "main" ; "unit" ; "0" ] ; - [%expect {|( list[] , 0 ) |}] + [%expect {|( LIST_EMPTY() , 0 ) |}] let%expect_test _ = run_ligo_good [ "dry-run" ; contract "double_main.ligo" ; "main" ; "unit" ; "0" ] ; - [%expect {|( list[] , 2 ) |}] + [%expect {|( LIST_EMPTY() , 2 ) |}] let%expect_test _ = run_ligo_good [ "compile-contract" ; contract "subtle_nontail_fail.mligo" ; "main" ] ; @@ -1155,7 +1098,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_good [ "dry-run" ; contract "super-counter.mligo" ; "main" ; "test_param" ; "test_storage" ] ; [%expect {| - ( list[] , 3 ) |}] + ( LIST_EMPTY() , 3 ) |}] let%expect_test _ = run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ; @@ -1174,7 +1117,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#654 = #P in let p = rhs#654.0 in let s = rhs#654.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} +ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#702 = #P in let p = rhs#702.0 in let s = rhs#702.1 in ( LIST_EMPTY() : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} If you're not sure how to fix this error, you can @@ -1187,7 +1130,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#657 = #P in let p = rhs#657.0 in let s = rhs#657.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} +ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#705 = #P in let p = rhs#705.0 in let s = rhs#705.1 in ( LIST_EMPTY() : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} If you're not sure how to fix this error, you can @@ -1396,4 +1339,4 @@ let%expect_test _ = * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ * Ask a question on our Discord: https://discord.gg/9rhYaEt * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new - * Check the changelog by running 'ligo changelog' |}] \ No newline at end of file + * Check the changelog by running 'ligo changelog' |}] diff --git a/src/bin/expect_tests/ligo_interpreter_tests.ml b/src/bin/expect_tests/ligo_interpreter_tests.ml index 9a6069338..5910c0669 100644 --- a/src/bin/expect_tests/ligo_interpreter_tests.ml +++ b/src/bin/expect_tests/ligo_interpreter_tests.ml @@ -43,12 +43,12 @@ let%expect_test _ = val map_finds = Some(2 : int) val map_finds_fail = "failed map find" : failure val map_empty = { ; 0 = ([]) ; 1 = ([]) } - val m = [ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int] + val m = [ ; "one" : string -> 1 : int ; "three" : string -> 3 : int ; "two" : string -> 2 : int] val map_fold = 4 : int val map_iter = unit - val map_map = [ ; "one" : string -> 4 : int ; "two" : string -> 5 : int ; "three" : string -> 8 : int] + val map_map = [ ; "one" : string -> 4 : int ; "three" : string -> 8 : int ; "two" : string -> 5 : int] val map_mem = { ; 0 = (true) ; 1 = (false) } - val map_remove = { ; 0 = ([ ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) } + val map_remove = { ; 0 = ([ ; "three" : string -> 3 : int ; "two" : string -> 2 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "three" : string -> 3 : int ; "two" : string -> 2 : int]) } val map_update = { ; 0 = ([ ; "one" : string -> 1 : int]) ; 1 = ([]) ; 2 = ([]) ; 3 = ([ ; "one" : string -> 1 : int]) } val s = { ; 1 : int ; 2 : int ; 3 : int} val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) } diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index ecf5ce7e3..facf1e75c 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -175,7 +175,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_good [ "interpret" ; "Set.literal [ (1,(2,3)) ; (2,(3,4)) ]" ; "--syntax=cameligo" ] ; [%expect {| - set[( 2 , ( 3 , 4 ) ) , ( 1 , ( 2 , 3 ) )] |}]; + SET_ADD(( 2 , ( 3 , 4 ) ) , SET_ADD(( 1 , ( 2 , 3 ) ) , SET_EMPTY())) |}]; run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ; [%expect {| diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo.md b/src/passes/1-parser/pascaligo/Doc/pascaligo.md index 1415631fd..ba6010ea8 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo.md +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo.md @@ -823,7 +823,7 @@ example, in verbose style: type store is record - goal : mutez; // Millionth of a tez + goal : tez; deadline : timestamp; backers : map (address, nat); funded : bool diff --git a/src/passes/1-parser/reasonligo/error.messages.checked-in b/src/passes/1-parser/reasonligo/error.messages.checked-in index a6c93721e..370f32c8a 100644 --- a/src/passes/1-parser/reasonligo/error.messages.checked-in +++ b/src/passes/1-parser/reasonligo/error.messages.checked-in @@ -2945,7 +2945,7 @@ This is an incorrect let binding. Examples of correct let bindings: let a: int = 4; let (a: int, b: int) = (1, 2); -let func = (a: int, b: int) => a + b +let func = (a: int, b: int) => a + b; contract: Let Ident WILD ## diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index 1a04d35c4..f4d930298 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -119,6 +119,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result = | ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b') | ( C_AND , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' && b') | ( C_XOR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool ( (a' || b') && (not (a' && b')) ) + | ( C_LIST_EMPTY, []) -> ok @@ V_List ([]) | ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) -> let%bind elts' = bind_map_list (fun elt -> @@ -170,6 +171,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result = eval body env' ) init elts + | ( C_MAP_EMPTY , []) -> ok @@ V_Map ([]) | ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) -> bind_fold_list (fun prev kv -> @@ -188,6 +190,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result = | "None" -> ok @@ V_Map (List.remove_assoc k kvs) | _ -> simple_fail "update without an option" ) + | ( C_SET_EMPTY, []) -> ok @@ V_Set ([]) | ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l)) | ( C_SET_FOLD , [ V_Func_val (arg_name, body, env) ; V_Set elts ; init ] ) -> bind_fold_list @@ -289,22 +292,6 @@ and eval : Ast_typed.expression -> env -> value result let%bind rhs' = eval rhs env in eval let_result (Env.extend env (let_binder,rhs')) ) - | E_map kvlist | E_big_map kvlist -> - let%bind kvlist' = bind_map_list - (fun kv -> bind_map_pair (fun (el:Ast_typed.expression) -> eval el env) kv) - kvlist in - ok @@ V_Map kvlist' - | E_list expl -> - let%bind expl' = bind_map_list - (fun (exp:Ast_typed.expression) -> eval exp env) - expl in - ok @@ V_List expl' - | E_set expl -> - let%bind expl' = bind_map_list - (fun (exp:Ast_typed.expression) -> eval exp env) - (List.sort_uniq compare expl) - in - ok @@ V_Set expl' | E_literal l -> eval_literal l | E_variable var -> @@ -316,12 +303,12 @@ and eval : Ast_typed.expression -> env -> value result ok (label,v')) (LMap.to_kv_list recmap) in ok @@ V_Record (LMap.of_list lv') - | E_record_accessor { expr ; label} -> ( - let%bind record' = eval expr env in + | E_record_accessor { record ; path} -> ( + let%bind record' = eval record env in match record' with | V_Record recmap -> let%bind a = trace_option (simple_error "unknown record field") @@ - LMap.find_opt label recmap in + LMap.find_opt path recmap in ok a | _ -> simple_fail "trying to access a non-record" ) @@ -378,9 +365,6 @@ and eval : Ast_typed.expression -> env -> value result ) | E_recursive {fun_name; fun_type=_; lambda} -> ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env) - | E_look_up _ -> - let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in - simple_fail serr let dummy : Ast_typed.program -> string result = fun prg -> diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 2d726d2df..5f89f5a20 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -141,6 +141,8 @@ let rec transpile_type (t:AST.type_expression) : type_value result = | T_operator (TC_big_map (key,value)) -> let%bind kv' = bind_map_pair transpile_type (key, value) in ok (T_big_map kv') + | T_operator (TC_map_or_big_map (_,_)) -> + fail @@ corner_case ~loc:"transpiler" "TC_map_or_big_map should have been resolved before transpilation" | T_operator (TC_list t) -> let%bind t' = transpile_type t in ok (T_list t') @@ -170,7 +172,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result = aux node in ok @@ snd m' | T_record m -> - let node = Append_tree.of_list @@ kv_list_of_lmap m in + let node = Append_tree.of_list @@ Stage_common.Helpers.kv_list_of_record_or_tuple m in let aux a b : type_value annotated result = let%bind a = a in let%bind b = b in @@ -189,7 +191,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result = ) let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind -> - let tys = kv_list_of_lmap tym in + let tys = Stage_common.Helpers.kv_list_of_record_or_tuple tym in let node_tv = Append_tree.of_list tys in let%bind path = let aux (i , _) = i = ind in @@ -234,7 +236,6 @@ and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression and transpile_annotated_expression (ae:AST.expression) : expression result = let%bind tv = transpile_type ae.type_expression in let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in - let f = transpile_annotated_expression in let info = let title () = "translating expression" in let content () = Format.asprintf "%a" Location.pp ae.location in @@ -289,7 +290,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return ~tv ae ) | E_record m -> ( - let node = Append_tree.of_list @@ list_of_lmap m in + (*list_of_lmap to record_to_list*) + let node = Append_tree.of_list @@ Stage_common.Helpers.list_of_record_or_tuple m in let aux a b : expression result = let%bind a = a in let%bind b = b in @@ -301,21 +303,21 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = trace_strong (corner_case ~loc:__LOC__ "record build") @@ Append_tree.fold_ne (transpile_annotated_expression) aux node ) - | E_record_accessor {expr; label} -> - let%bind ty' = transpile_type (get_type_expression expr) in + | E_record_accessor {record; path} -> + let%bind ty' = transpile_type (get_type_expression record) in let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ - get_t_record (get_type_expression expr) in + get_t_record (get_type_expression record) in let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ - record_access_to_lr ty' ty'_lmap label in + record_access_to_lr ty' ty'_lmap path in let aux = fun pred (ty, lr) -> let c = match lr with | `Left -> C_CAR | `Right -> C_CDR in Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in - let%bind record' = transpile_annotated_expression expr in + let%bind record' = transpile_annotated_expression record in let expr = List.fold_left aux record' path in ok expr | E_record_update {record; path; update} -> @@ -390,58 +392,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = transpile_lambda l io | E_recursive r -> transpile_recursive r - | E_list lst -> ( - let%bind t = - trace_strong (corner_case ~loc:__LOC__ "not a list") @@ - get_t_list tv in - let%bind lst' = bind_map_list (transpile_annotated_expression) lst in - let aux : expression -> expression -> expression result = fun prev cur -> - return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in - let%bind (init : expression) = return @@ E_make_empty_list t in - bind_fold_right_list aux init lst' - ) - | E_set lst -> ( - let%bind t = - trace_strong (corner_case ~loc:__LOC__ "not a set") @@ - get_t_set tv in - let%bind lst' = bind_map_list (transpile_annotated_expression) lst in - let aux : expression -> expression -> expression result = fun prev cur -> - return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in - let%bind (init : expression) = return @@ E_make_empty_set t in - bind_fold_list aux init lst' - ) - | E_map m -> ( - let%bind (src, dst) = - trace_strong (corner_case ~loc:__LOC__ "not a map") @@ - Mini_c.Combinators.get_t_map tv in - let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) -> - let%bind prev' = prev in - let%bind (k', v') = - let v' = e_a_some v ae.environment in - bind_map_pair (transpile_annotated_expression) (k , v') in - return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']} - in - let init = return @@ E_make_empty_map (src, dst) in - List.fold_left aux init m - ) - | E_big_map m -> ( - let%bind (src, dst) = - trace_strong (corner_case ~loc:__LOC__ "not a map") @@ - Mini_c.Combinators.get_t_big_map tv in - let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) -> - let%bind prev' = prev in - let%bind (k', v') = - let v' = e_a_some v ae.environment in - bind_map_pair (transpile_annotated_expression) (k , v') in - return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']} - in - let init = return @@ E_make_empty_big_map (src, dst) in - List.fold_left aux init m - ) - | E_look_up dsi -> ( - let%bind (ds', i') = bind_map_pair f dsi in - return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']} - ) | E_matching {matchee=expr; cases=m} -> ( let%bind expr' = transpile_annotated_expression expr in match m with diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 49f9cde37..3665f8063 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -151,29 +151,41 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul ok (e_a_empty_some s') ) | TC_map (k_ty,v_ty)-> ( - let%bind lst = + let%bind map = trace_strong (wrong_mini_c_value "map" v) @@ get_map v in - let%bind lst' = + let%bind map' = let aux = fun (k, v) -> let%bind k' = untranspile k k_ty in let%bind v' = untranspile v v_ty in ok (k', v') in - bind_map_list aux lst in - return (E_map lst') + bind_map_list aux map in + let map' = List.sort_uniq compare map' in + let aux = fun prev (k, v) -> + let (k', v') = (k , v ) in + return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]} + in + let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in + bind_fold_right_list aux init map' ) | TC_big_map (k_ty, v_ty) -> ( - let%bind lst = + let%bind big_map = trace_strong (wrong_mini_c_value "big_map" v) @@ get_big_map v in - let%bind lst' = + let%bind big_map' = let aux = fun (k, v) -> let%bind k' = untranspile k k_ty in let%bind v' = untranspile v v_ty in ok (k', v') in - bind_map_list aux lst in - return (E_big_map lst') + bind_map_list aux big_map in + let big_map' = List.sort_uniq compare big_map' in + let aux = fun prev (k, v) -> + return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]} + in + let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in + bind_fold_right_list aux init big_map' ) + | TC_map_or_big_map (_, _) -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c" | TC_list ty -> ( let%bind lst = trace_strong (wrong_mini_c_value "list" v) @@ @@ -181,7 +193,10 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind lst' = let aux = fun e -> untranspile e ty in bind_map_list aux lst in - return (E_list lst') + let aux = fun prev cur -> + return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in + let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in + bind_fold_right_list aux init lst' ) | TC_arrow _ -> ( let%bind n = @@ -196,7 +211,11 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind lst' = let aux = fun e -> untranspile e ty in bind_map_list aux lst in - return (E_set lst') + let lst' = List.sort_uniq compare lst' in + let aux = fun prev cur -> + return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in + let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in + bind_fold_list aux init lst' ) | TC_contract _ -> fail @@ bad_untranspile "contract" v @@ -213,7 +232,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind sub = untranspile v tv in return (E_constructor {constructor=Constructor name;element=sub}) | T_record m -> - let lst = kv_list_of_lmap m in + let lst = Stage_common.Helpers.kv_list_of_record_or_tuple m in let%bind node = match Append_tree.of_list lst with | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" | Full t -> ok t in diff --git a/src/passes/11-self_mini_c/helpers.ml b/src/passes/11-self_mini_c/helpers.ml index 6b77cf2ee..fd35db639 100644 --- a/src/passes/11-self_mini_c/helpers.ml +++ b/src/passes/11-self_mini_c/helpers.ml @@ -25,12 +25,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind init' = f init e in match e.content with | E_variable _ | E_skip | E_make_none _ - | E_make_empty_map _ - | E_make_empty_big_map _ - | E_make_empty_list _ - | E_make_empty_set _ -> ( - ok init' - ) | E_literal _ -> ok init' | E_constant (c) -> ( let%bind res = bind_fold_list self init' c.arguments in @@ -94,10 +88,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let return content = ok { e' with content } in match e'.content with | E_variable _ | E_literal _ | E_skip | E_make_none _ - | E_make_empty_map _ - | E_make_empty_big_map _ - | E_make_empty_list _ - | E_make_empty_set _ as em -> return em + as em -> return em | E_constant (c) -> ( let%bind lst = bind_map_list self c.arguments in return @@ E_constant {cons_name = c.cons_name; arguments = lst} diff --git a/src/passes/11-self_mini_c/self_mini_c.ml b/src/passes/11-self_mini_c/self_mini_c.ml index 66a0a06b8..95e03a661 100644 --- a/src/passes/11-self_mini_c/self_mini_c.ml +++ b/src/passes/11-self_mini_c/self_mini_c.ml @@ -47,10 +47,6 @@ let rec is_pure : expression -> bool = fun e -> | E_closure _ | E_skip | E_variable _ - | E_make_empty_map _ - | E_make_empty_big_map _ - | E_make_empty_list _ - | E_make_empty_set _ | E_make_none _ -> true diff --git a/src/passes/11-self_mini_c/subst.ml b/src/passes/11-self_mini_c/subst.ml index c2103c9f5..1637a7bbe 100644 --- a/src/passes/11-self_mini_c/subst.ml +++ b/src/passes/11-self_mini_c/subst.ml @@ -40,10 +40,6 @@ let rec replace : expression -> var_name -> var_name -> expression = | E_variable z -> let z = replace_var z in return @@ E_variable z - | E_make_empty_map _ -> e - | E_make_empty_big_map _ -> e - | E_make_empty_list _ -> e - | E_make_empty_set _ -> e | E_make_none _ -> e | E_iterator (name, ((v, tv), body), expr) -> let body = replace body in @@ -175,10 +171,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e ) (* All that follows is boilerplate *) | E_literal _ | E_skip | E_make_none _ - | E_make_empty_map (_,_) - | E_make_empty_big_map _ - | E_make_empty_list _ - | E_make_empty_set _ as em -> return em + as em -> return em | E_constant (c) -> ( let lst = List.map self c.arguments in return @@ E_constant {cons_name = c.cons_name; arguments = lst } diff --git a/src/passes/12-compiler/compiler_program.ml b/src/passes/12-compiler/compiler_program.ml index 9a2001298..200bd0cf9 100644 --- a/src/passes/12-compiler/compiler_program.ml +++ b/src/passes/12-compiler/compiler_program.ml @@ -66,10 +66,25 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r let%bind m_ty = Compiler_type.type_ ty in ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT ) + | C_LIST_EMPTY -> ( + let%bind ty' = Mini_c.get_t_list ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_constant @@ i_nil m_ty + ) | C_SET_EMPTY -> ( let%bind ty' = Mini_c.get_t_set ty in let%bind m_ty = Compiler_type.type_ ty' in - ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET + ok @@ simple_constant @@ i_empty_set m_ty + ) + | C_MAP_EMPTY -> ( + let%bind sd = Mini_c.get_t_map ty in + let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in + ok @@ simple_constant @@ i_empty_map src dst + ) + | C_BIG_MAP_EMPTY -> ( + let%bind sd = Mini_c.get_t_big_map ty in + let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in + ok @@ simple_constant @@ i_empty_big_map src dst ) | C_BYTES_UNPACK -> ( let%bind ty' = Mini_c.get_t_option ty in @@ -297,18 +312,6 @@ and translate_expression (expr:expression) (env:environment) : michelson result error title content in trace error @@ return code - | E_make_empty_map sd -> - let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in - return @@ i_empty_map src dst - | E_make_empty_big_map sd -> - let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in - return @@ i_empty_big_map src dst - | E_make_empty_list t -> - let%bind t' = Compiler_type.type_ t in - return @@ i_nil t' - | E_make_empty_set t -> - let%bind t' = Compiler_type.type_ t in - return @@ i_empty_set t' | E_make_none o -> let%bind o' = Compiler_type.type_ o in return @@ i_none o' diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index f6b2ef165..371e0c784 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -383,11 +383,10 @@ let rec compile_expression : match variables with | hd :: [] -> if (List.length prep_vars = 1) - then e_let_in hd false inline rhs_b_expr body - else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body + then e_let_in hd inline rhs_b_expr body + else e_let_in hd inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body | hd :: tl -> e_let_in hd - false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1))) (chain_let_in tl body) @@ -408,7 +407,7 @@ let rec compile_expression : let%bind ret_expr = if List.length prep_vars = 1 then ok (chain_let_in prep_vars body) (* Bind the right hand side so we only evaluate it once *) - else ok (e_let_in (rhs_b, ty_opt) false inline rhs' (chain_let_in prep_vars body)) + else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body)) in let%bind ret_expr = match kwd_rec with | None -> ok @@ ret_expr @@ -572,7 +571,7 @@ let rec compile_expression : | Raw.PVar y -> let var_name = Var.of_name y.value in let%bind type_expr = compile_type_expression x'.type_expr in - return @@ e_let_in (var_name , Some type_expr) false false e rhs + return @@ e_let_in (var_name , Some type_expr) false e rhs | _ -> default_action () ) | _ -> default_action () diff --git a/src/passes/2-concrete_to_imperative/dune b/src/passes/2-concrete_to_imperative/dune index c3f316ce4..1aa60f304 100644 --- a/src/passes/2-concrete_to_imperative/dune +++ b/src/passes/2-concrete_to_imperative/dune @@ -6,7 +6,6 @@ tezos-utils parser ast_imperative - self_ast_imperative operators) (modules cameligo pascaligo concrete_to_imperative) (preprocess diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 7823cfb4e..2eb055351 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -14,92 +14,6 @@ let pseq_to_list = function | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value -and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = - let%bind captured_names = Self_ast_imperative.fold_map_expression - (* TODO : these should use Variables sets *) - (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> - match ass_exp.expression_content with - | E_let_in {let_binder;mut=false;rhs;let_result} -> - let (name,_) = let_binder in - ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result) - | E_let_in {let_binder;mut=true; rhs;let_result} -> - let (name,_) = let_binder in - if List.mem name decl_var then - ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result) - else( - let free_var = if (List.mem name free_var) then free_var else name::free_var in - let expr = e_let_in (env,None) false false (e_update (e_variable env) (Var.to_name name) (e_variable name)) let_result in - ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr) - ) - | E_variable name -> - if List.mem name decl_var || List.mem name free_var || Var.equal name env then - ok (true,(decl_var, free_var), e_variable name) - else - ok (true, (decl_var, name::free_var), e_variable name) - | E_constant {cons_name=C_MAP_FOLD;arguments= _} - | E_constant {cons_name=C_SET_FOLD;arguments= _} - | E_constant {cons_name=C_LIST_FOLD;arguments= _} - | E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp) - | _ -> ok (true, (decl_var, free_var),ass_exp) - ) - (element_names,[]) - for_body in - ok @@ captured_names - -and repair_mutable_variable_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = - let%bind captured_names = Self_ast_imperative.fold_map_expression - (* TODO : these should use Variables sets *) - (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> - match ass_exp.expression_content with - | E_let_in {let_binder;mut=false;rhs;let_result} -> - let (name,_) = let_binder in - ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result) - | E_let_in {let_binder;mut=true; rhs;let_result} -> - let (name,_) = let_binder in - if List.mem name decl_var then - ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result) - else( - let free_var = if (List.mem name free_var) then free_var else name::free_var in - let expr = e_let_in (env,None) false false ( - e_update (e_variable env) ("0") - (e_update (e_accessor (e_variable env) "0") (Var.to_name name) (e_variable name)) - ) - let_result in - ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr) - ) - | E_variable name -> - if List.mem name decl_var || List.mem name free_var || Var.equal name env then - ok (true,(decl_var, free_var), e_variable name) - else - ok (true,(decl_var, name::free_var), e_variable name) - | E_constant {cons_name=C_MAP_FOLD;arguments= _} - | E_constant {cons_name=C_SET_FOLD;arguments= _} - | E_constant {cons_name=C_LIST_FOLD;arguments= _} - | E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp) - | _ -> ok (true,(decl_var, free_var),ass_exp) - ) - (element_names,[]) - for_body in - ok @@ captured_names - -and store_mutable_variable (free_vars : expression_variable list) = - if (List.length free_vars == 0) then - e_unit () - else - let aux var = (Var.to_name var, e_variable var) in - e_record_ez (List.map aux free_vars) - -and restore_mutable_variable (expr : expression->expression) (free_vars : expression_variable list) (env :expression_variable) = - let aux (f:expression -> expression) (ev:expression_variable) = - ok @@ fun expr -> f (e_let_in (ev,None) true false (e_accessor (e_variable env) (Var.to_name ev)) expr) - in - let%bind ef = bind_fold_list aux (fun e -> e) free_vars in - ok @@ fun expr'_opt -> match expr'_opt with - | None -> ok @@ expr (ef (e_skip ())) - | Some expr' -> ok @@ expr (ef expr') - - - module Errors = struct let unsupported_cst_constr p = let title () = "" in @@ -218,10 +132,10 @@ let r_split = Location.r_split [return_statement] is used for non-let-in statements. *) -let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt -> +let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt -> match expr'_opt with - | None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ()) - | Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr' + | None -> ok @@ e_let_in ?loc binder inline rhs (e_skip ()) + | Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr' let return_statement expr = ok @@ fun expr'_opt -> match expr'_opt with @@ -433,10 +347,7 @@ let rec compile_expression (t:Raw.expr) : expr result = 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 match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in - let env = Var.fresh () in - let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in - return @@ match_expr + return @@ e_matching expr ~loc (Match_bool {match_true; match_false}) | ECase c -> ( let (c , loc) = r_split c in @@ -450,10 +361,7 @@ let rec compile_expression (t:Raw.expr) : expr result = @@ List.map get_value @@ npseq_to_list c.cases.value in let%bind cases = compile_cases lst in - let match_expr = e_matching ~loc e cases in - let env = Var.fresh () in - let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in - return @@ match_expr + return @@ e_matching ~loc e cases ) | EMap (MapInj mi) -> ( let (mi , loc) = r_split mi in @@ -615,7 +523,7 @@ and compile_data_declaration : Raw.data_decl -> _ result = let name = x.name.value in let%bind t = compile_type_expression x.var_type in let%bind expression = compile_expression x.init in - return_let_in ~loc (Var.of_name name, Some t) false false expression + return_let_in ~loc (Var.of_name name, Some t) false expression | LocalConst x -> let (x , loc) = r_split x in let name = x.name.value in @@ -627,7 +535,7 @@ and compile_data_declaration : Raw.data_decl -> _ result = | Some {value; _} -> npseq_to_list value.ne_elements |> List.exists (fun Region.{value; _} -> value = "\"inline\"") - in return_let_in ~loc (Var.of_name name, Some t) false inline expression + in return_let_in ~loc (Var.of_name name, Some t) inline expression | LocalFun f -> let (f , loc) = r_split f in let%bind (binder, expr) = compile_fun_decl ~loc f in @@ -637,7 +545,7 @@ and compile_data_declaration : Raw.data_decl -> _ result = | Some {value; _} -> npseq_to_list value.ne_elements |> List.exists (fun Region.{value; _} -> value = "\"inline\"") - in return_let_in ~loc binder false inline expr + in return_let_in ~loc binder inline expr and compile_param : Raw.param_decl -> (string * type_expression) result = @@ -708,7 +616,7 @@ and compile_fun_decl : let expr = e_accessor (e_variable arguments_name) (string_of_int i) in let type_variable = Some type_expr in - let ass = return_let_in (Var.of_name param , type_variable) false inline expr in + let ass = return_let_in (Var.of_name param , type_variable) inline expr in ass in bind_list @@ List.mapi aux params in @@ -771,7 +679,7 @@ and compile_fun_expression : let aux = fun i (param, param_type) -> let expr = e_accessor (e_variable arguments_name) (string_of_int i) in let type_variable = Some param_type in - let ass = return_let_in (Var.of_name param , type_variable) false false expr in + let ass = return_let_in (Var.of_name param , type_variable) false expr in ass in bind_list @@ List.mapi aux params in @@ -819,35 +727,6 @@ and compile_statement_list statements = hook (compile_data_declaration d :: acc) statements in bind_list @@ hook [] (List.rev statements) -and get_case_variables (t:Raw.pattern) : expression_variable list result = - match t with - | PConstr PFalse _ - | PConstr PTrue _ - | PConstr PNone _ -> ok @@ [] - | PConstr PSomeApp v -> (let (_,v) = v.value in get_case_variables (v.value.inside)) - | PConstr PConstrApp v -> ( - match v.value with - | constr, None -> ok @@ [ Var.of_name constr.value] - | constr, pat_opt -> - let%bind pat = - trace_option (unsupported_cst_constr t) @@ - pat_opt in - let pat = npseq_to_list pat.value.inside in - let%bind var = bind_map_list get_case_variables pat in - ok @@ [Var.of_name constr.value ] @ (List.concat var) - ) - | PList PNil _ -> ok @@ [] - | PList PCons c -> ( - match c.value with - | a, [(_, b)] -> - let%bind a = get_case_variables a in - let%bind b = get_case_variables b in - ok @@ a@b - | _ -> fail @@ unsupported_deep_list_patterns c - ) - | PVar v -> ok @@ [Var.of_name v.value] - | p -> fail @@ unsupported_cst_constr p - and compile_single_instruction : Raw.instruction -> (_ -> expression result) result = fun t -> match t with @@ -877,14 +756,33 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res return_statement @@ e_skip ~loc () ) | Loop (While l) -> - compile_while_loop l.value + let (wl, loc) = r_split l in + let%bind condition = compile_expression wl.cond in + let%bind body = compile_block wl.block.value in + let%bind body = body @@ None in + return_statement @@ e_while ~loc condition body | Loop (For (ForInt fi)) -> ( - let%bind loop = compile_for_int fi.value in - ok loop + let (fi,loc) = r_split fi in + let binder = Var.of_name fi.assign.value.name.value in + let%bind start = compile_expression fi.assign.value.expr in + let%bind bound = compile_expression fi.bound in + let increment = e_int 1 in + let%bind body = compile_block fi.block.value in + let%bind body = body @@ None in + return_statement @@ e_for ~loc binder start bound increment body ) | Loop (For (ForCollect fc)) -> - let%bind loop = compile_for_collect fc.value in - ok loop + let (fc,loc) = r_split fc in + let binder = (Var.of_name fc.var.value, Option.map (fun x -> Var.of_name (snd x:string Raw.reg).value) fc.bind_to) in + let%bind collection = compile_expression fc.expr in + let collection_type = match fc.collection with + | Map _ -> Map + | Set _ -> Set + | List _ -> List + in + let%bind body = compile_block fc.block.value in + let%bind body = body @@ None in + return_statement @@ e_for_each ~loc binder collection collection_type body | Cond c -> ( let (c , loc) = r_split c in let%bind expr = compile_expression c.test in @@ -906,26 +804,10 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res compile_block value | ShortBlock {value; _} -> compile_statements @@ fst value.inside in - let env = Var.fresh () in - let%bind match_true' = match_true None in - let%bind match_false' = match_false None in - let%bind match_true = match_true @@ Some (e_variable env) in - let%bind match_false = match_false @@ Some (e_variable env) in - - let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true [] env in - let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching match_false [] env in - let free_vars = free_vars_true @ free_vars_false in - if (List.length free_vars != 0) then - let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in - let return_expr = fun expr -> - e_let_in (env,None) false false (store_mutable_variable free_vars) @@ - e_let_in (env,None) false false match_expr @@ - expr - in - restore_mutable_variable return_expr free_vars env - else - return_statement @@ e_matching expr ~loc (Match_bool {match_true=match_true'; match_false=match_false'}) + let%bind match_true = match_true None in + let%bind match_false = match_false None in + return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false}) ) | Assign a -> ( let (a , loc) = r_split a in @@ -933,8 +815,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res match a.lhs with | Path path -> ( let (name , path') = compile_path path in - let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in - return_let_in let_binder mut inline rhs + return_statement @@ e_ez_assign ~loc name path' value_expr ) | MapPath v -> ( let v' = v.value in @@ -947,16 +828,14 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res in let%bind key_expr = compile_expression v'.index.value.inside in let expr' = e_map_add key_expr value_expr map in - let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in - return_let_in let_binder mut inline rhs + return_statement @@ e_ez_assign ~loc varname path expr' ) ) | CaseInstr c -> ( let (c , loc) = r_split c in let%bind expr = compile_expression c.expr in - let env = Var.fresh () in - let%bind (fv,cases) = - let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) = + let%bind cases = + let aux (x : Raw.if_clause Raw.case_clause Raw.reg) = let%bind case_clause = match x.value.rhs with ClauseInstr i -> @@ -967,28 +846,13 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res compile_block value | ShortBlock {value; _} -> compile_statements @@ fst value.inside in - let%bind case_clause'= case_clause @@ None in - let%bind case_clause = case_clause @@ Some(e_variable env) in - let%bind case_vars = get_case_variables x.value.pattern in - let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching case_clause case_vars env in - ok (free_vars::fv,(x.value.pattern, case_clause, case_clause')) in - bind_fold_map_list aux [] (npseq_to_list c.cases.value) in - let free_vars = List.concat fv in - if (List.length free_vars == 0) then ( - let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in - let%bind m = compile_cases cases in - return_statement @@ e_matching ~loc expr m - ) else ( - let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in - let%bind m = compile_cases cases in - let match_expr = e_matching ~loc expr m in - let return_expr = fun expr -> - e_let_in (env,None) false false (store_mutable_variable free_vars) @@ - e_let_in (env,None) false false match_expr @@ - expr - in - restore_mutable_variable return_expr free_vars env - ) + let%bind case_clause = case_clause None in + ok (x.value.pattern, case_clause) in + bind_list + @@ List.map aux + @@ npseq_to_list c.cases.value in + let%bind m = compile_cases cases in + return_statement @@ e_matching ~loc expr m ) | RecordPatch r -> ( let reg = r.region in @@ -1004,9 +868,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in let%bind expr = compile_update {value=u;region=reg} in let (name , access_path) = compile_path r.path in - let loc = Some loc in - let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc name access_path expr ) | MapPatch patch -> ( @@ -1029,8 +891,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc name access_path assigns ) | SetPatch patch -> ( let (setp, loc) = r_split patch in @@ -1045,8 +906,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res let assigns = List.fold_right (fun hd s -> e_constant C_SET_ADD [hd ; s]) inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc name access_path assigns ) | MapRemove r -> ( let (v , loc) = r_split r in @@ -1060,8 +920,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res in let%bind key' = compile_expression key in let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc varname path expr ) | SetRemove r -> ( let (set_rm, loc) = r_split r in @@ -1074,8 +933,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res in let%bind removed' = compile_expression set_rm.element in let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc varname path expr ) and compile_path : Raw.path -> string * string list = fun p -> @@ -1204,121 +1062,6 @@ and compile_statements : Raw.statements -> (_ -> expression result) result = and compile_block : Raw.block -> (_ -> expression result) result = fun t -> compile_statements t.statements -and compile_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl -> - let env_rec = Var.fresh () in - let binder = Var.fresh () in - - let%bind cond = compile_expression wl.cond in - let ctrl = - (e_variable binder) - in - - let%bind for_body = compile_block wl.block.value in - let%bind for_body = for_body @@ Some( ctrl ) in - let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in - - let aux name expr= - e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr - in - let init_rec = e_tuple [store_mutable_variable @@ captured_name_list] in - let restore = fun expr -> List.fold_right aux captured_name_list expr in - let continue_expr = e_constant C_FOLD_CONTINUE [for_body] in - let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in - let aux_func = - e_lambda binder None None @@ - restore @@ - e_cond cond continue_expr stop_expr in - let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in - let return_expr = fun expr -> - e_let_in (env_rec,None) false false init_rec @@ - e_let_in (env_rec,None) false false loop @@ - e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@ - expr - in - restore_mutable_variable return_expr captured_name_list env_rec - - -and compile_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> - let env_rec = Var.fresh () in - let binder = Var.fresh () in - let name = fi.assign.value.name.value in - let it = Var.of_name name in - let var = e_variable it in - (*Make the cond and the step *) - let%bind value = compile_expression fi.assign.value.expr in - let%bind bound = compile_expression fi.bound in - let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in - let step = e_int 1 in - let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in - let ctrl = - e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ]) @@ - e_let_in (binder, None) false false (e_update (e_variable binder) "1" var)@@ - continue_expr - in - (* Modify the body loop*) - let%bind for_body = compile_block fi.block.value in - let%bind for_body = for_body @@ Some ctrl in - let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in - - let aux name expr= - e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr - in - - (* restores the initial value of the free_var*) - let restore = fun expr -> List.fold_right aux captured_name_list expr in - - (*Prep the lambda for the fold*) - let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in - let aux_func = e_lambda binder None None @@ - e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) "1") @@ - e_cond cond (restore for_body) (stop_expr) in - - (* Make the fold_while en precharge the vakye *) - let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in - let init_rec = e_pair (store_mutable_variable @@ captured_name_list) var in - - let return_expr = fun expr -> - e_let_in (it, Some t_int) false false value @@ - e_let_in (env_rec,None) false false init_rec @@ - e_let_in (env_rec,None) false false loop @@ - e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@ - expr - in - restore_mutable_variable return_expr captured_name_list env_rec - -and compile_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> - let binder = Var.of_name "arguments" in - let%bind element_names = ok @@ match fc.bind_to with - | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] - | None -> [Var.of_name fc.var.value] in - - let env = Var.fresh () in - let%bind for_body = compile_block fc.block.value in - let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in - let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in - - let init_record = store_mutable_variable free_vars in - let%bind collect = compile_expression fc.expr in - let aux name expr= - e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr - in - let restore = fun expr -> List.fold_right aux free_vars expr in - let restore = match fc.collection with - | Map _ -> (match fc.bind_to with - | Some v -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") - (e_let_in (Var.of_name (snd v).value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "1") expr)) - | None -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") expr) - ) - | _ -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_variable binder) "1") expr) - in - let lambda = e_lambda binder None None (restore for_body) in - let op_name = match fc.collection with - | Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in - let fold = fun expr -> - e_let_in (env,None) false false (e_constant op_name [lambda; collect ; init_record]) @@ - expr - in - restore_mutable_variable fold free_vars env and compile_declaration_list declarations : declaration Location.wrap list result = let open Raw in diff --git a/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml b/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml index f2d5fc202..e9809c835 100644 --- a/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml +++ b/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml @@ -11,7 +11,7 @@ end open Errors let peephole_type_expression : type_expression -> type_expression result = fun e -> - let return type_content = ok { e with type_content } in + let return type_content = ok {type_content } in match e.type_content with | T_sum cmap -> let%bind _uu = bind_map_cmapi diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index fc15f29e1..47626335f 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -47,8 +47,25 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = fold_expression self res update in ok res ) - | E_record_accessor {expr} -> ( - let%bind res = self init' expr in + | E_record_accessor {record} -> ( + let%bind res = self init' record in + ok res + ) + | E_tuple t -> ( + let aux init'' expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_list aux (init') t in + ok res + ) + | E_tuple_update {tuple;update} -> ( + let%bind res = self init' tuple in + let%bind res = fold_expression self res update in + ok res + ) + | E_tuple_accessor {tuple} -> ( + let%bind res = self init' tuple in ok res ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( @@ -59,10 +76,30 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini | E_recursive { lambda={result=e;_}; _} -> let%bind res = self init' e in ok res + | E_cond {condition; then_clause; else_clause} -> + let%bind res = self init' condition in + let%bind res = self res then_clause in + let%bind res = self res else_clause in + ok res | E_sequence {expr1;expr2} -> let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in ok res + | E_assign {variable=_;access_path=_;expression} -> + let%bind res = self init' expression in + ok res + | E_for {body; _} -> + let%bind res = self init' body in + ok res + | E_for_each {collection; body; _} -> + let%bind res = self init' collection in + let%bind res = self res body in + ok res + | E_while {condition; body} -> + let%bind res = self init' condition in + let%bind res = self res body in + ok res + and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> @@ -134,8 +171,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e return @@ E_matching {matchee=e';cases=cases'} ) | E_record_accessor acc -> ( - let%bind e' = self acc.expr in - return @@ E_record_accessor {acc with expr = e'} + let%bind e' = self acc.record in + return @@ E_record_accessor {acc with record = e'} ) | E_record m -> ( let%bind m' = bind_map_lmap self m in @@ -146,6 +183,19 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind update = self update in return @@ E_record_update {record;path;update} ) + | E_tuple t -> ( + let%bind t' = bind_map_list self t in + return @@ E_tuple t' + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind tuple = self tuple in + let%bind update = self update in + return @@ E_tuple_update {tuple; path; update} + ) + | E_tuple_accessor {tuple;path} -> ( + let%bind tuple = self tuple in + return @@ E_tuple_accessor {tuple;path} + ) | E_constructor c -> ( let%bind e' = self c.element in return @@ E_constructor {c with element = e'} @@ -155,10 +205,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind (lamb,args) = bind_map_pair self ab in return @@ E_application {lamb;args} ) - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( + | E_let_in { let_binder ; rhs ; let_result; inline } -> ( let%bind rhs = self rhs in let%bind let_result = self let_result in - return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline } + return @@ E_let_in { let_binder ; rhs ; let_result; inline } ) | E_lambda { binder ; input_type ; output_type ; result } -> ( let%bind result = self result in @@ -172,16 +222,37 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} ) + | E_cond {condition; then_clause; else_clause} -> + let%bind condition = self condition in + let%bind then_clause = self then_clause in + let%bind else_clause = self else_clause in + return @@ E_cond {condition;then_clause;else_clause} | E_sequence {expr1;expr2} -> ( let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} ) + | E_assign {variable;access_path;expression} -> ( + let%bind expression = self expression in + return @@ E_assign {variable;access_path;expression} + ) + | E_for {binder; start; final; increment; body} -> + let%bind body = self body in + return @@ E_for {binder; start; final; increment; body} + | E_for_each {binder; collection; collection_type; body} -> + let%bind collection = self collection in + let%bind body = self body in + return @@ E_for_each {binder; collection; collection_type; body} + | E_while {condition; body} -> + let%bind condition = self condition in + let%bind body = self body in + return @@ E_while {condition; body} + | E_literal _ | E_variable _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> let self = map_type_expression f in let%bind te' = f te in - let return type_content = ok { te' with type_content } in + let return type_content = ok { type_content } in match te'.type_content with | T_sum temap -> let%bind temap' = bind_map_cmap self temap in @@ -189,6 +260,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re | T_record temap -> let%bind temap' = bind_map_lmap self temap in return @@ (T_record temap') + | T_tuple telst -> + let%bind telst' = bind_map_list self telst in + return @@ (T_tuple telst') | T_arrow {type1 ; type2} -> let%bind type1' = self type1 in let%bind type2' = self type2 in @@ -280,8 +354,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres ok (res, return @@ E_matching {matchee=e';cases=cases'}) ) | E_record_accessor acc -> ( - let%bind (res, e') = self init' acc.expr in - ok (res, return @@ E_record_accessor {acc with expr = e'}) + let%bind (res, e') = self init' acc.record in + ok (res, return @@ E_record_accessor {acc with record = e'}) ) | E_record m -> ( let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in @@ -293,6 +367,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, update) = self res update in ok (res, return @@ E_record_update {record;path;update}) ) + | E_tuple t -> ( + let%bind (res, t') = bind_fold_map_list self init' t in + ok (res, return @@ E_tuple t') + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind (res, tuple) = self init' tuple in + let%bind (res, update) = self res update in + ok (res, return @@ E_tuple_update {tuple;path;update}) + ) + | E_tuple_accessor {tuple; path} -> ( + let%bind (res, tuple) = self init' tuple in + ok (res, return @@ E_tuple_accessor {tuple; path}) + ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) @@ -302,10 +389,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in ok (res, return @@ E_application {lamb=a;args=b}) ) - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( + | E_let_in { let_binder ; rhs ; let_result; inline } -> ( let%bind (res,rhs) = self init' rhs in let%bind (res,let_result) = self res let_result in - ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline }) + ok (res, return @@ E_let_in { let_binder ; rhs ; let_result ; inline }) ) | E_lambda { binder ; input_type ; output_type ; result } -> ( let%bind (res,result) = self init' result in @@ -319,10 +406,29 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res,condition = self init' condition in + let%bind res,then_clause = self res then_clause in + let%bind res,else_clause = self res else_clause in + ok (res, return @@ E_cond {condition;then_clause;else_clause}) | E_sequence {expr1;expr2} -> ( let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in ok (res, return @@ E_sequence {expr1;expr2}) ) + | E_assign {variable;access_path;expression} -> + let%bind (res, expression) = self init' expression in + ok (res, return @@ E_assign {variable;access_path;expression}) + | E_for {binder; start; final; increment; body} -> + let%bind (res, body) = self init' body in + ok (res, return @@ E_for {binder; start; final; increment; body}) + | E_for_each {binder; collection; collection_type; body} -> + let%bind res,collection = self init' collection in + let%bind res,body = self res body in + ok (res, return @@ E_for_each {binder; collection; collection_type; body}) + | E_while {condition; body} -> + let%bind res,condition = self init' condition in + let%bind res,body = self res body in + ok (res, return @@ E_while {condition; body}) | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> diff --git a/src/passes/4-imperative_to_sugar/dune b/src/passes/4-imperative_to_sugar/dune index 445998b90..66f996558 100644 --- a/src/passes/4-imperative_to_sugar/dune +++ b/src/passes/4-imperative_to_sugar/dune @@ -5,6 +5,7 @@ simple-utils ast_imperative ast_sugar + self_ast_sugar proto-alpha-utils ) (preprocess diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 9cdfed78e..4a69e6c67 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -2,6 +2,105 @@ module I = Ast_imperative module O = Ast_sugar open Trace +module Errors = struct + let bad_collection expr = + let title () = "" in + let message () = Format.asprintf "\nCannot loop over this collection : %a\n" I.PP.expression expr in + let data = [ + ("location", + fun () -> Format.asprintf "%a" Location.pp expr.location) + ] in + error ~data title message +end + +let rec add_to_end (expression: O.expression) to_add = + match expression.expression_content with + | O.E_let_in lt -> + let lt = {lt with let_result = add_to_end lt.let_result to_add} in + {expression with expression_content = O.E_let_in lt} + | O.E_sequence seq -> + let seq = {seq with expr2 = add_to_end seq.expr2 to_add} in + {expression with expression_content = O.E_sequence seq} + | _ -> O.e_sequence expression to_add + +let repair_mutable_variable_in_matching (match_body : O.expression) (element_names : O.expression_variable list) (env : I.expression_variable) = + let%bind ((dv,fv),mb) = Self_ast_sugar.fold_map_expression + (* TODO : these should use Variables sets *) + (fun (decl_var,free_var : O.expression_variable list * O.expression_variable list) (ass_exp : O.expression) -> + match ass_exp.expression_content with + | E_let_in {let_binder;mut=false;rhs;let_result} -> + let (name,_) = let_binder in + ok (true,(name::decl_var, free_var),O.e_let_in let_binder false false rhs let_result) + | E_let_in {let_binder;mut=true; rhs;let_result} -> + let (name,_) = let_binder in + if List.mem name decl_var then + ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result) + else( + let free_var = if (List.mem name free_var) then free_var else name::free_var in + let expr = O.e_let_in (env,None) false false (O.e_record_update (O.e_variable env) (Var.to_name name) (O.e_variable name)) let_result in + ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) + ) + | E_constant {cons_name=C_MAP_FOLD;arguments= _} + | E_constant {cons_name=C_SET_FOLD;arguments= _} + | E_constant {cons_name=C_LIST_FOLD;arguments= _} + | E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp) + | _ -> ok (true, (decl_var, free_var),ass_exp) + ) + (element_names,[]) + match_body in + ok @@ ((dv,fv),mb) + +and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : O.expression_variable list) (env : O.expression_variable) = + let%bind ((dv,fv),fb) = Self_ast_sugar.fold_map_expression + (* TODO : these should use Variables sets *) + (fun (decl_var,free_var : O.expression_variable list * O.expression_variable list) (ass_exp : O.expression) -> + (* Format.printf "debug: dv:%a; fv:%a; expr:%a \n%!" + (I.PP.list_sep_d I.PP.expression_variable) decl_var + (I.PP.list_sep_d I.PP.expression_variable) decl_var + O.PP.expression ass_exp + ;*) + match ass_exp.expression_content with + | E_let_in {let_binder;mut=false;} -> + let (name,_) = let_binder in + ok (true,(name::decl_var, free_var),ass_exp) + | E_let_in {let_binder;mut=true; rhs;let_result} -> + let (name,_) = let_binder in + if List.mem name decl_var then + ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result) + else( + let free_var = if (List.mem name free_var) then free_var else name::free_var in + let expr = O.e_let_in (env,None) false false ( + O.e_record_update (O.e_variable env) ("0") + (O.e_record_update (O.e_record_accessor (O.e_variable env) "0") (Var.to_name name) (O.e_variable name)) + ) + let_result in + ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) + ) + | E_constant {cons_name=C_MAP_FOLD;arguments= _} + | E_constant {cons_name=C_SET_FOLD;arguments= _} + | E_constant {cons_name=C_LIST_FOLD;arguments= _} + | E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp) + | _ -> ok (true,(decl_var, free_var),ass_exp) + ) + (element_names,[]) + for_body in + ok @@ ((dv,fv),fb) + +and store_mutable_variable (free_vars : I.expression_variable list) = + if (List.length free_vars == 0) then + O.e_unit () + else + let aux var = (Var.to_name var, O.e_variable var) in + O.e_record_ez (List.map aux free_vars) + +and restore_mutable_variable (expr : O.expression->O.expression_content) (free_vars : O.expression_variable list) (env : O.expression_variable) = + let aux (f: O.expression -> O.expression) (ev: O.expression_variable) = + fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Var.to_name ev)) expr) + in + let ef = List.fold_left aux (fun e -> e) free_vars in + expr (ef (O.e_skip ())) + + let rec compile_type_expression : I.type_expression -> O.type_expression result = fun te -> let return te = ok @@ O.make_t te in @@ -24,6 +123,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result ) record in return @@ O.T_record (O.LMap.of_list record) + | I.T_tuple tuple -> + let%bind tuple = bind_map_list compile_type_expression tuple in + return @@ O.T_tuple tuple | I.T_arrow {type1;type2} -> let%bind type1 = compile_type_expression type1 in let%bind type2 = compile_type_expression type2 in @@ -79,19 +181,18 @@ let rec compile_expression : I.expression -> O.expression result = let%bind fun_type = compile_type_expression fun_type in let%bind lambda = compile_lambda lambda in return @@ O.E_recursive {fun_name;fun_type;lambda} - | I.E_let_in {let_binder;mut=_;inline;rhs;let_result} -> + | I.E_let_in {let_binder;inline;rhs;let_result} -> let (binder,ty_opt) = let_binder in let%bind ty_opt = bind_map_option compile_type_expression ty_opt in 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} + return @@ O.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.E_constructor {constructor;element} - | I.E_matching {matchee; cases} -> - let%bind matchee = compile_expression matchee in - let%bind cases = compile_matching cases in - return @@ O.E_matching {matchee;cases} + | I.E_matching m -> + let%bind m = compile_matching m in + return @@ m | I.E_record record -> let record = I.LMap.to_kv_list record in let%bind record = @@ -101,9 +202,9 @@ let rec compile_expression : I.expression -> O.expression result = ) record in return @@ O.E_record (O.LMap.of_list record) - | I.E_record_accessor {expr;label} -> - let%bind expr = compile_expression expr in - return @@ O.E_record_accessor {expr;label} + | I.E_record_accessor {record;path} -> + let%bind record = compile_expression record in + return @@ O.E_record_accessor {record;path} | I.E_record_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in @@ -133,46 +234,305 @@ let rec compile_expression : I.expression -> O.expression result = let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = compile_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} + | I.E_cond {condition;then_clause;else_clause} -> + 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%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 + let else_clause = add_to_end else_clause (O.e_variable env) in + + let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in + if (List.length free_vars != 0) then + let cond_expr = O.e_cond condition then_clause else_clause in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false cond_expr @@ + expr + } + in + return @@ restore_mutable_variable return_expr free_vars env + else + return @@ O.E_cond {condition; then_clause=then_clause'; else_clause=else_clause'} | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in - return @@ O.E_sequence {expr1; expr2} + ok @@ add_to_end expr1 expr2 | I.E_skip -> return @@ O.E_skip + | I.E_tuple tuple -> + let%bind tuple = bind_map_list compile_expression tuple in + return @@ O.E_tuple (tuple) + | I.E_tuple_accessor {tuple;path} -> + let%bind tuple = compile_expression tuple in + return @@ O.E_tuple_accessor {tuple;path} + | I.E_tuple_update {tuple;path;update} -> + let%bind tuple = compile_expression tuple in + let%bind update = compile_expression update in + return @@ O.E_tuple_update {tuple;path;update} + | I.E_assign ass -> + let%bind content = compile_assign ass @@ O.e_skip () in + return @@ content + | I.E_for f -> + let%bind f = compile_for f in + return @@ f + | I.E_for_each fe -> + let%bind fe = compile_for_each fe in + return @@ fe + | I.E_while w -> + let%bind w = compile_while w in + return @@ w + +and compile_assign {variable; access_path; expression} expr = + let accessor ?loc s a = + match a with + I.Access_tuple _i -> failwith "adding tuple soon" + | I.Access_record a -> ok @@ O.e_record_accessor ?loc s a + | I.Access_map k -> + let%bind k = compile_expression k in + ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;s] + in + let update ?loc (s:O.expression) a e = + match a with + I.Access_tuple _i -> failwith "adding tuple soon" + | I.Access_record a -> ok @@ O.e_record_update ?loc s a e + | I.Access_map k -> + let%bind k = compile_expression k in + ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s] + in + let aux (s, e : O.expression * _) lst = + let%bind s' = accessor ~loc:s.location s lst in + let e' = fun expr -> + let%bind u = update ~loc:s.location s lst (expr) + in e u + in + ok @@ (s',e') + in + let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in + let%bind expression = compile_expression expression in + let%bind rhs = rhs @@ expression in + ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false} + and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> let%bind input_type = bind_map_option compile_type_expression input_type in 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 : I.matching_expr -> O.matching_expr result = - fun m -> - match m with + +and compile_matching : I.matching -> O.expression_content result = + fun {matchee;cases} -> + let%bind matchee = compile_expression matchee in + match cases with | I.Match_bool {match_true;match_false} -> - let%bind match_true = compile_expression match_true in - let%bind match_false = compile_expression match_false in - ok @@ O.Match_bool {match_true;match_false} - | I.Match_list {match_nil;match_cons} -> - let%bind match_nil = compile_expression match_nil in - let (hd,tl,expr,tv) = match_cons in - let%bind expr = compile_expression expr in - ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + let%bind match_true' = compile_expression match_true in + let%bind match_false' = compile_expression match_false in + let env = Var.fresh () in + let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true' [] env in + let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching match_false' [] env in + let match_true = add_to_end match_true (O.e_variable env) in + let match_false = add_to_end match_false (O.e_variable env) in + + let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in + if (List.length free_vars != 0) then + let match_expr = O.e_matching matchee (O.Match_bool {match_true; match_false}) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + else + ok @@ O.E_matching {matchee;cases=O.Match_bool {match_true=match_true';match_false=match_false'}} | I.Match_option {match_none;match_some} -> - let%bind match_none = compile_expression match_none in + let%bind match_none' = compile_expression match_none in let (n,expr,tv) = match_some in - let%bind expr = compile_expression expr in - ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} + let%bind expr' = compile_expression expr in + let env = Var.fresh () 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 + let expr = add_to_end expr (O.e_variable env) in + let free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in + if (List.length free_vars != 0) then + let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + else + ok @@ O.E_matching {matchee; cases=O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}} + | I.Match_list {match_nil;match_cons} -> + let%bind match_nil' = compile_expression match_nil in + let (hd,tl,expr,tv) = match_cons in + let%bind expr' = compile_expression expr in + let env = Var.fresh () 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 + let expr = add_to_end expr (O.e_variable env) in + let free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in + if (List.length free_vars != 0) then + let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + else + ok @@ O.E_matching {matchee;cases=O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}} | I.Match_tuple ((lst,expr), tv) -> let%bind expr = compile_expression expr in - ok @@ O.Match_tuple ((lst,expr), tv) + ok @@ O.E_matching {matchee; cases=O.Match_tuple ((lst,expr), tv)} | I.Match_variant (lst,tv) -> - let%bind lst = bind_map_list ( - fun ((c,n),expr) -> - let%bind expr = compile_expression expr in - ok @@ ((c,n),expr) - ) lst - in - ok @@ O.Match_variant (lst,tv) + let env = Var.fresh () 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 + let case_clause'= expr in + let case_clause = add_to_end case_clause (O.e_variable env) in + ok (free_vars::fv,((c,n), case_clause, case_clause')) in + let%bind (fv,cases) = bind_fold_map_list aux [] lst in + let free_vars = List.sort_uniq Var.compare @@ List.concat fv in + if (List.length free_vars == 0) then ( + let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in + ok @@ O.E_matching{matchee; cases=O.Match_variant (cases,tv)} + ) else ( + let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in + let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false; rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + ) +and compile_while I.{condition;body} = + let env_rec = Var.fresh () in + let binder = Var.fresh () in + + let%bind cond = compile_expression condition in + let ctrl = + (O.e_variable binder) + in + + let%bind for_body = compile_expression body in + let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in + let for_body = add_to_end for_body ctrl in + + let aux name expr= + O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable binder) "0") (Var.to_name name)) expr + in + let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in + let restore = fun expr -> List.fold_right aux captured_name_list expr in + let continue_expr = O.e_constant C_FOLD_CONTINUE [for_body] in + let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable binder] in + let aux_func = + O.e_lambda binder None None @@ + restore @@ + O.e_cond cond continue_expr stop_expr in + let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in + let let_binder = (env_rec,None) in + let return_expr = fun expr -> + O.E_let_in {let_binder; mut=false; inline=false; rhs=init_rec; let_result= + O.e_let_in let_binder false false loop @@ + O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) "0") @@ + expr + } + in + ok @@ restore_mutable_variable return_expr captured_name_list env_rec + + +and compile_for I.{binder;start;final;increment;body} = + let env_rec = Var.fresh () 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 + let%bind step = compile_expression increment in + let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in + let ctrl = + O.e_let_in (binder,Some O.t_int) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@ + O.e_let_in (env_rec, None) false false (O.e_record_update (O.e_variable env_rec) "1" @@ O.e_variable binder)@@ + continue_expr + in + (* Modify the body loop*) + let%bind body = compile_expression body in + let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops body [binder] env_rec in + let for_body = add_to_end for_body ctrl in + + let aux name expr= + O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable env_rec) "0") (Var.to_name name)) expr + in + + (* restores the initial value of the free_var*) + let restore = fun expr -> List.fold_right aux captured_name_list expr in + + (*Prep the lambda for the fold*) + let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in + let aux_func = O.e_lambda env_rec None None @@ + O.e_let_in (binder,Some O.t_int) false false (O.e_record_accessor (O.e_variable env_rec) "1") @@ + O.e_cond cond (restore for_body) (stop_expr) in + + (* Make the fold_while en precharge the vakye *) + let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in + let init_rec = O.e_pair (store_mutable_variable captured_name_list) @@ O.e_variable binder in + + let%bind start = compile_expression start in + let let_binder = (env_rec,None) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(binder, Some O.t_int);mut=false; inline=false;rhs=start;let_result= + O.e_let_in let_binder false false init_rec @@ + O.e_let_in let_binder false false loop @@ + O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) "0") @@ + expr + } + in + ok @@ restore_mutable_variable return_expr captured_name_list env_rec + +and compile_for_each I.{binder;collection;collection_type; body} = + let args = Var.fresh () in + let%bind element_names = ok @@ match snd binder with + | Some v -> [fst binder;v] + | None -> [fst binder] + in + + let env = Var.fresh () in + let%bind body = compile_expression body in + let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in + let for_body = add_to_end body @@ (O.e_record_accessor (O.e_variable args) "0") in + + let init_record = store_mutable_variable free_vars in + let%bind collect = compile_expression collection in + let aux name expr= + O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "0") (Var.to_name name)) expr + in + let restore = fun expr -> List.fold_right aux free_vars expr in + let restore = match collection_type with + | Map -> (match snd binder with + | Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "0") + (O.e_let_in (v, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "1") expr)) + | None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "0") expr) + ) + | _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_variable args) "1") expr) + in + let lambda = O.e_lambda args None None (restore for_body) in + let%bind op_name = match collection_type with + | Map -> ok @@ O.C_MAP_FOLD | Set -> ok @@ O.C_SET_FOLD | List -> ok @@ O.C_LIST_FOLD + in + let fold = fun expr -> + O.E_let_in {let_binder=(env,None);mut=false; inline=false;rhs=(O.e_constant op_name [lambda; collect ; init_record]); + let_result=expr;} + in + ok @@ restore_mutable_variable fold free_vars env let compile_declaration : I.declaration Location.wrap -> _ = fun {wrap_content=declaration;location} -> let return decl = ok @@ Location.wrap ~loc:location decl in @@ -212,6 +572,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul ) record in return @@ I.T_record (O.LMap.of_list record) + | O.T_tuple tuple -> + let%bind tuple = bind_map_list uncompile_type_expression tuple in + return @@ I.T_tuple tuple | O.T_arrow {type1;type2} -> let%bind type1 = uncompile_type_expression type1 in let%bind type2 = uncompile_type_expression type2 in @@ -272,7 +635,7 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in 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} + return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} @@ -289,13 +652,23 @@ let rec uncompile_expression : O.expression -> I.expression result = ) record in return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {expr;label} -> - let%bind expr = uncompile_expression expr in - return @@ I.E_record_accessor {expr;label} + | O.E_record_accessor {record;path} -> + let%bind record = uncompile_expression record in + return @@ I.E_record_accessor {record;path} | O.E_record_update {record;path;update} -> let%bind record = uncompile_expression record in let%bind update = uncompile_expression update in return @@ I.E_record_update {record;path;update} + | O.E_tuple tuple -> + let%bind tuple = bind_map_list uncompile_expression tuple in + return @@ I.E_tuple tuple + | O.E_tuple_accessor {tuple;path} -> + let%bind tuple = uncompile_expression tuple in + return @@ I.E_tuple_accessor {tuple;path} + | O.E_tuple_update {tuple;path;update} -> + let%bind tuple = uncompile_expression tuple in + let%bind update = uncompile_expression update in + return @@ I.E_tuple_update {tuple;path;update} | O.E_map map -> let%bind map = bind_map_list ( bind_map_pair uncompile_expression @@ -321,6 +694,11 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind anno_expr = uncompile_expression anno_expr in let%bind type_annotation = uncompile_type_expression type_annotation in return @@ I.E_ascription {anno_expr; type_annotation} + | O.E_cond {condition;then_clause;else_clause} -> + let%bind condition = uncompile_expression condition in + let%bind then_clause = uncompile_expression then_clause in + let%bind else_clause = uncompile_expression else_clause in + return @@ I.E_cond {condition; then_clause; else_clause} | O.E_sequence {expr1; expr2} -> let%bind expr1 = uncompile_expression expr1 in let%bind expr2 = uncompile_expression expr2 in diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml new file mode 100644 index 000000000..7ac208768 --- /dev/null +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -0,0 +1,417 @@ +open Ast_sugar +open Trace +open Stage_common.Helpers + +type 'a folder = 'a -> expression -> 'a result +let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> + let self = fold_expression f in + let%bind init' = f init e in + match e.expression_content with + | E_literal _ | E_variable _ | E_skip -> ok init' + | E_list lst | E_set lst | E_constant {arguments=lst} -> ( + let%bind res = bind_fold_list self init' lst in + ok res + ) + | E_map lst | E_big_map lst -> ( + let%bind res = bind_fold_list (bind_fold_pair self) init' lst in + ok res + ) + | E_look_up ab -> + let%bind res = bind_fold_pair self init' ab in + ok res + | E_application {lamb;args} -> ( + let ab = (lamb,args) in + let%bind res = bind_fold_pair self init' ab in + ok res + ) + | E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e } + | E_ascription {anno_expr=e; _} | E_constructor {element=e} -> ( + let%bind res = self init' e in + ok res + ) + | E_matching {matchee=e; cases} -> ( + let%bind res = self init' e in + let%bind res = fold_cases f res cases in + ok res + ) + | E_record m -> ( + let aux init'' _ expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_lmap aux (ok init') m in + ok res + ) + | E_record_update {record;update} -> ( + let%bind res = self init' record in + let%bind res = fold_expression self res update in + ok res + ) + | E_record_accessor {record} -> ( + let%bind res = self init' record in + ok res + ) + | E_let_in { let_binder = _ ; rhs ; let_result } -> ( + let%bind res = self init' rhs in + let%bind res = self res let_result in + ok res + ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res = self init' condition in + let%bind res = self res then_clause in + let%bind res = self res else_clause in + ok res + | E_recursive { lambda={result=e;_}; _} -> + let%bind res = self init' e in + ok res + | E_sequence {expr1;expr2} -> + let ab = (expr1,expr2) in + let%bind res = bind_fold_pair self init' ab in + ok res + | E_tuple t -> ( + let aux init'' expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_list aux (init') t in + ok res + ) + | E_tuple_update {tuple;update} -> ( + let%bind res = self init' tuple in + let%bind res = fold_expression self res update in + ok res + ) + | E_tuple_accessor {tuple} -> ( + let%bind res = self init' tuple in + ok res + ) + + +and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind res = fold_expression f init match_true in + let%bind res = fold_expression f res match_false in + ok res + ) + | Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> ( + let%bind res = fold_expression f init match_nil in + let%bind res = fold_expression f res cons in + ok res + ) + | Match_option { match_none ; match_some = (_ , some, _) } -> ( + let%bind res = fold_expression f init match_none in + let%bind res = fold_expression f res some in + ok res + ) + | Match_tuple ((_ , e), _) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_variant (lst, _) -> ( + let aux init' ((_ , _) , e) = + let%bind res' = fold_expression f init' e in + ok res' in + let%bind res = bind_fold_list aux init lst in + ok res + ) + +type exp_mapper = expression -> expression result +type ty_exp_mapper = type_expression -> type_expression result +type abs_mapper = + | Expression of exp_mapper + | Type_expression of ty_exp_mapper +let rec map_expression : exp_mapper -> expression -> expression 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 + match e'.expression_content with + | E_list lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_list lst' + ) + | E_set lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_set lst' + ) + | E_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_map lst' + ) + | E_big_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_big_map lst' + ) + | E_look_up ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_look_up ab' + ) + | E_ascription ascr -> ( + let%bind e' = self ascr.anno_expr in + return @@ E_ascription {ascr with anno_expr=e'} + ) + | E_matching {matchee=e;cases} -> ( + let%bind e' = self e in + let%bind cases' = map_cases f cases in + return @@ E_matching {matchee=e';cases=cases'} + ) + | E_record_accessor acc -> ( + let%bind e' = self acc.record in + return @@ E_record_accessor {acc with record = e'} + ) + | E_record m -> ( + let%bind m' = bind_map_lmap self m in + return @@ E_record m' + ) + | E_record_update {record; path; update} -> ( + let%bind record = self record in + let%bind update = self update in + return @@ E_record_update {record;path;update} + ) + | E_constructor c -> ( + let%bind e' = self c.element in + return @@ E_constructor {c with element = e'} + ) + | E_application {lamb;args} -> ( + let ab = (lamb,args) in + let%bind (lamb,args) = bind_map_pair self ab in + return @@ E_application {lamb;args} + ) + | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( + let%bind rhs = self rhs in + let%bind let_result = self let_result in + return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline } + ) + | E_lambda { binder ; input_type ; output_type ; result } -> ( + let%bind result = self result in + return @@ E_lambda { binder ; input_type ; output_type ; result } + ) + | E_recursive { fun_name; fun_type; lambda} -> + let%bind result = self lambda.result in + let lambda = {lambda with result} in + return @@ E_recursive { fun_name; fun_type; lambda} + | E_constant c -> ( + let%bind args = bind_map_list self c.arguments in + return @@ E_constant {c with arguments=args} + ) + | E_cond {condition; then_clause; else_clause} -> + let%bind condition = self condition in + let%bind then_clause = self then_clause in + let%bind else_clause = self else_clause in + return @@ E_cond {condition;then_clause;else_clause} + | E_sequence {expr1;expr2} -> ( + let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in + return @@ E_sequence {expr1;expr2} + ) + | E_tuple t -> ( + let%bind t' = bind_map_list self t in + return @@ E_tuple t' + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind tuple = self tuple in + let%bind update = self update in + return @@ E_tuple_update {tuple; path; update} + ) + | E_tuple_accessor {tuple;path} -> ( + let%bind tuple = self tuple in + return @@ E_tuple_accessor {tuple;path} + ) + | E_literal _ | E_variable _ | E_skip as e' -> return e' + +and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> + let self = map_type_expression f in + let%bind te' = f te in + let return type_content = ok { type_content } in + match te'.type_content with + | T_sum temap -> + let%bind temap' = bind_map_cmap self temap in + return @@ (T_sum temap') + | T_record temap -> + let%bind temap' = bind_map_lmap self temap in + return @@ (T_record temap') + | T_tuple telst -> + let%bind telst' = bind_map_list self telst in + return @@ (T_tuple telst') + | T_arrow {type1 ; type2} -> + let%bind type1' = self type1 in + let%bind type2' = self type2 in + return @@ (T_arrow {type1=type1' ; type2=type2'}) + | T_operator _ + | T_variable _ | T_constant _ -> ok te' + +and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind match_true = map_expression f match_true in + let%bind match_false = map_expression f match_false in + ok @@ Match_bool { match_true ; match_false } + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( + let%bind match_nil = map_expression f match_nil in + let%bind cons = map_expression f cons in + ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) } + ) + | Match_option { match_none ; match_some = (name , some, _) } -> ( + let%bind match_none = map_expression f match_none in + let%bind some = map_expression f some in + ok @@ Match_option { match_none ; match_some = (name , some, ()) } + ) + | Match_tuple ((names , e), _) -> ( + let%bind e' = map_expression f e in + ok @@ Match_tuple ((names , e'), []) + ) + | Match_variant (lst, _) -> ( + let aux ((a , b) , e) = + let%bind e' = map_expression f e in + ok ((a , b) , e') + in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant (lst', ()) + ) + +and map_program : abs_mapper -> program -> program result = fun m p -> + let aux = fun (x : declaration) -> + match x,m with + | (Declaration_constant (t , o , i, e), Expression m') -> ( + let%bind e' = map_expression m' e in + ok (Declaration_constant (t , o , i, e')) + ) + | (Declaration_type (tv,te), Type_expression m') -> ( + let%bind te' = map_type_expression m' te in + ok (Declaration_type (tv, te')) + ) + | decl,_ -> ok decl + (* | Declaration_type of (type_variable * type_expression) *) + in + bind_map_list (bind_map_location aux) p + +type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result +let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e -> + let self = fold_map_expression f in + let%bind (continue, init',e') = f a e in + if (not continue) then ok(init',e') + else + let return expression_content = { e' with expression_content } in + match e'.expression_content with + | E_list lst -> ( + let%bind (res, lst') = bind_fold_map_list self init' lst in + ok (res, return @@ E_list lst') + ) + | E_set lst -> ( + let%bind (res, lst') = bind_fold_map_list self init' lst in + ok (res, return @@ E_set lst') + ) + | E_map lst -> ( + let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in + ok (res, return @@ E_map lst') + ) + | E_big_map lst -> ( + let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in + ok (res, return @@ E_big_map lst') + ) + | E_look_up ab -> ( + let%bind (res, ab') = bind_fold_map_pair self init' ab in + ok (res, return @@ E_look_up ab') + ) + | E_ascription ascr -> ( + let%bind (res,e') = self init' ascr.anno_expr in + ok (res, return @@ E_ascription {ascr with anno_expr=e'}) + ) + | E_matching {matchee=e;cases} -> ( + let%bind (res, e') = self init' e in + let%bind (res,cases') = fold_map_cases f res cases in + ok (res, return @@ E_matching {matchee=e';cases=cases'}) + ) + | E_record_accessor acc -> ( + let%bind (res, e') = self init' acc.record in + ok (res, return @@ E_record_accessor {acc with record = e'}) + ) + | E_record m -> ( + let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in + let m' = LMap.of_list lst' in + ok (res, return @@ E_record m') + ) + | E_record_update {record; path; update} -> ( + let%bind (res, record) = self init' record in + let%bind (res, update) = self res update in + ok (res, return @@ E_record_update {record;path;update}) + ) + | E_tuple t -> ( + let%bind (res, t') = bind_fold_map_list self init' t in + ok (res, return @@ E_tuple t') + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind (res, tuple) = self init' tuple in + let%bind (res, update) = self res update in + ok (res, return @@ E_tuple_update {tuple;path;update}) + ) + | E_tuple_accessor {tuple; path} -> ( + let%bind (res, tuple) = self init' tuple in + ok (res, return @@ E_tuple_accessor {tuple; path}) + ) + | E_constructor c -> ( + let%bind (res,e') = self init' c.element in + ok (res, return @@ E_constructor {c with element = e'}) + ) + | E_application {lamb;args} -> ( + let ab = (lamb,args) in + let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in + ok (res, return @@ E_application {lamb=a;args=b}) + ) + | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( + let%bind (res,rhs) = self init' rhs in + let%bind (res,let_result) = self res let_result in + ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline }) + ) + | E_lambda { binder ; input_type ; output_type ; result } -> ( + let%bind (res,result) = self init' result in + ok ( res, return @@ E_lambda { binder ; input_type ; output_type ; result }) + ) + | E_recursive { fun_name; fun_type; lambda} -> + let%bind (res, result) = self init' lambda.result in + let lambda = {lambda with result} in + ok ( res, return @@ E_recursive { fun_name; fun_type; lambda}) + | E_constant c -> ( + let%bind (res,args) = bind_fold_map_list self init' c.arguments in + ok (res, return @@ E_constant {c with arguments=args}) + ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res,condition = self init' condition in + let%bind res,then_clause = self res then_clause in + let%bind res,else_clause = self res else_clause in + ok (res, return @@ E_cond {condition;then_clause;else_clause}) + | E_sequence {expr1;expr2} -> ( + let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in + ok (res, return @@ E_sequence {expr1;expr2}) + ) + | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') + +and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind (init, match_true) = fold_map_expression f init match_true in + let%bind (init, match_false) = fold_map_expression f init match_false in + ok @@ (init, Match_bool { match_true ; match_false }) + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( + let%bind (init, match_nil) = fold_map_expression f init match_nil in + let%bind (init, cons) = fold_map_expression f init cons in + ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }) + ) + | Match_option { match_none ; match_some = (name , some, _) } -> ( + let%bind (init, match_none) = fold_map_expression f init match_none in + let%bind (init, some) = fold_map_expression f init some in + ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) }) + ) + | Match_tuple ((names , e), _) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_tuple ((names , e'), [])) + ) + | Match_variant (lst, _) -> ( + let aux init ((a , b) , e) = + let%bind (init,e') = fold_map_expression f init e in + ok (init, ((a , b) , e')) + in + let%bind (init,lst') = bind_fold_map_list aux init lst in + ok @@ (init, Match_variant (lst', ())) + ) diff --git a/src/passes/5-self_ast_sugar/self_ast_sugar.ml b/src/passes/5-self_ast_sugar/self_ast_sugar.ml new file mode 100644 index 000000000..5bac36236 --- /dev/null +++ b/src/passes/5-self_ast_sugar/self_ast_sugar.ml @@ -0,0 +1,25 @@ +open Trace + +let all_expression_mapper = [ +] + +let all_type_expression_mapper = [ +] + +let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper +let all_ty = List.map (fun el -> Helpers.Type_expression el) all_type_expression_mapper + +let all_program = + let all_p = List.map Helpers.map_program all_exp in + let all_p2 = List.map Helpers.map_program all_ty in + bind_chain (List.append all_p all_p2) + +let all_expression = + let all_p = List.map Helpers.map_expression all_expression_mapper in + bind_chain all_p + +let map_expression = Helpers.map_expression + +let fold_expression = Helpers.fold_expression + +let fold_map_expression = Helpers.fold_map_expression diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 261bb1e81..b175f8eb3 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -24,6 +24,13 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result = ) record in return @@ O.T_record (O.LMap.of_list record) + | I.T_tuple tuple -> + let aux (i,acc) el = + let%bind el = idle_type_expression el in + ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in + let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in + let record = O.LMap.of_list lst in + return @@ O.T_record record | I.T_arrow {type1;type2} -> let%bind type1 = idle_type_expression type1 in let%bind type2 = idle_type_expression type2 in @@ -101,43 +108,78 @@ let rec compile_expression : I.expression -> O.expression result = ) record in return @@ O.E_record (O.LMap.of_list record) - | I.E_record_accessor {expr;label} -> - let%bind expr = compile_expression expr in - return @@ O.E_record_accessor {expr;label} + | I.E_record_accessor {record;path} -> + let%bind record = compile_expression record in + return @@ O.E_record_accessor {record;path} | I.E_record_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in return @@ O.E_record_update {record;path;update} - | I.E_map map -> - let%bind map = bind_map_list ( - bind_map_pair compile_expression - ) map + | I.E_map map -> ( + let map = List.sort_uniq compare map in + let aux = fun prev (k, v) -> + let%bind (k', v') = bind_map_pair (compile_expression) (k, v) in + return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]} in - return @@ O.E_map map - | I.E_big_map big_map -> - let%bind big_map = bind_map_list ( - bind_map_pair compile_expression - ) big_map + let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in + bind_fold_right_list aux init map + ) + | I.E_big_map big_map -> ( + let big_map = List.sort_uniq compare big_map in + let aux = fun prev (k, v) -> + let%bind (k', v') = bind_map_pair (compile_expression) (k, v) in + return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]} in - return @@ O.E_big_map big_map + let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in + bind_fold_right_list aux init big_map + ) | I.E_list lst -> - let%bind lst = bind_map_list compile_expression lst in - return @@ O.E_list lst - | I.E_set set -> - let%bind set = bind_map_list compile_expression set in - return @@ O.E_set set + let%bind lst' = bind_map_list (compile_expression) lst in + let aux = fun prev cur -> + return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in + let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in + bind_fold_right_list aux init lst' + | I.E_set set -> ( + let%bind lst' = bind_map_list (compile_expression) set in + let lst' = List.sort_uniq compare lst' in + let aux = fun prev cur -> + return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in + let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in + bind_fold_list aux init lst' + ) | I.E_look_up look_up -> - let%bind look_up = bind_map_pair compile_expression look_up in - return @@ O.E_look_up look_up + let%bind (path, index) = bind_map_pair compile_expression look_up in + return @@ O.E_constant {cons_name=C_MAP_FIND_OPT;arguments=[index;path]} | I.E_ascription {anno_expr; type_annotation} -> let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = idle_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} + | I.E_cond {condition; then_clause; else_clause} -> + let%bind matchee = compile_expression condition in + let%bind match_true = compile_expression then_clause in + let%bind match_false = compile_expression else_clause in + return @@ O.E_matching {matchee; cases=Match_bool{match_true;match_false}} | I.E_sequence {expr1; expr2} -> 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_tuple t -> + let aux (i,acc) el = + let%bind el = compile_expression el in + ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in + let%bind (_, lst ) = bind_fold_list aux (0,[]) t in + let m = O.LMap.of_list lst in + return @@ O.E_record m + | I.E_tuple_accessor {tuple;path} -> + let%bind record = compile_expression tuple in + let path = O.Label (string_of_int path) in + return @@ O.E_record_accessor {record;path} + | I.E_tuple_update {tuple;path;update} -> + let%bind record = compile_expression tuple in + let path = O.Label (string_of_int path) in + let%bind update = compile_expression update in + return @@ O.E_record_update {record;path;update} and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> @@ -244,6 +286,7 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in ok @@ I.TC_big_map (k,v) + | TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled" | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in ok @@ I.TC_arrow (i,o) @@ -277,7 +320,7 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in 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} + return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} @@ -294,34 +337,13 @@ let rec uncompile_expression : O.expression -> I.expression result = ) record in return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {expr;label} -> - let%bind expr = uncompile_expression expr in - return @@ I.E_record_accessor {expr;label} + | O.E_record_accessor {record;path} -> + let%bind record = uncompile_expression record in + return @@ I.E_record_accessor {record;path} | O.E_record_update {record;path;update} -> let%bind record = uncompile_expression record in let%bind update = uncompile_expression update in return @@ I.E_record_update {record;path;update} - | O.E_map map -> - let%bind map = bind_map_list ( - bind_map_pair uncompile_expression - ) map - in - return @@ I.E_map map - | O.E_big_map big_map -> - let%bind big_map = bind_map_list ( - bind_map_pair uncompile_expression - ) big_map - in - return @@ I.E_big_map big_map - | O.E_list lst -> - let%bind lst = bind_map_list uncompile_expression lst in - return @@ I.E_list lst - | O.E_set set -> - let%bind set = bind_map_list uncompile_expression set in - return @@ I.E_set set - | O.E_look_up look_up -> - let%bind look_up = bind_map_pair uncompile_expression look_up in - return @@ I.E_look_up look_up | O.E_ascription {anno_expr; type_annotation} -> let%bind anno_expr = uncompile_expression anno_expr in let%bind type_annotation = uncompile_type_expression type_annotation in diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 328cfe015..25409822f 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -70,6 +70,7 @@ module Wrap = struct | TC_set s -> (C_set, [s]) | TC_map ( k , v ) -> (C_map, [k;v]) | TC_big_map ( k , v) -> (C_big_map, [k;v]) + | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) | TC_list l -> (C_list, [l]) | TC_contract c -> (C_contract, [c]) @@ -103,6 +104,7 @@ module Wrap = struct | TC_set s -> (C_set , [s]) | TC_map ( k , v ) -> (C_map , [k;v]) | TC_big_map ( k , v ) -> (C_big_map, [k;v]) + | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) | TC_contract c -> (C_contract, [c]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) ) diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 0dcae68d0..f9f6cf66a 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -163,7 +163,6 @@ end open Errors -let swap (a,b) = ok (b,a) (* let rec type_program (p:I.program) : O.program result = let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = @@ -346,6 +345,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_big_map (k,v) + | TC_map_or_big_map (k,v) -> + let%bind k = evaluate_type e k in + let%bind v = evaluate_type e v in + ok @@ O.TC_map_or_big_map (k,v) | TC_contract c -> let%bind c = evaluate_type e c in ok @@ O.TC_contract c @@ -452,10 +455,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - * | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) * | _ -> return (E_literal (Literal_string s)) (t_string ()) * ) *) - | E_record_accessor {expr;label} -> ( - let%bind (base' , state') = type_expression e state expr in - let wrapped = Wrap.access_label ~base:base'.type_expression ~label in - return_wrapped (E_record_accessor {expr=base';label}) state' wrapped + | E_record_accessor {record;path} -> ( + let%bind (base' , state') = type_expression e state record in + let wrapped = Wrap.access_label ~base:base'.type_expression ~label:path in + return_wrapped (E_record_accessor {record=base';path}) state' wrapped ) (* Sum *) @@ -503,140 +506,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped) (* Data-structure *) -(* - | E_list lst -> - let%bind lst' = bind_map_list (type_expression e) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind init = match tv_opt with - | None -> ok None - | Some ty -> - let%bind ty' = get_t_list ty in - ok (Some ty') in - let%bind ty = - let%bind opt = bind_fold_list aux init - @@ List.map get_type_annotation lst' in - trace_option (needs_annotation ae "empty list") opt in - ok (t_list ty ()) - in - return (E_list lst') tv - | E_set lst -> - let%bind lst' = bind_map_list (type_expression e) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind init = match tv_opt with - | None -> ok None - | Some ty -> - let%bind ty' = get_t_set ty in - ok (Some ty') in - let%bind ty = - let%bind opt = bind_fold_list aux init - @@ List.map get_type_annotation lst' in - trace_option (needs_annotation ae "empty set") opt in - ok (t_set ty ()) - in - return (E_set lst') tv - | E_map lst -> - let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - ok (Some c') in - let%bind key_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_map_key tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - let%bind value_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_annotation - @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_map_value tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - ok (t_map key_type value_type ()) - in - return (E_map lst') tv -*) - - | E_list lst -> - let%bind (state', lst') = - bind_fold_map_list (fun state' elt -> type_expression e state' elt >>? swap) state lst in - let wrapped = Wrap.list (List.map (fun x -> O.(x.type_expression)) lst') in - return_wrapped (E_list lst') state' wrapped - | E_set set -> - let aux = fun state' elt -> type_expression e state' elt >>? swap in - let%bind (state', set') = - bind_fold_map_list aux state set in - let wrapped = Wrap.set (List.map (fun x -> O.(x.type_expression)) set') in - return_wrapped (E_set set') state' wrapped - | E_map map -> - let aux' state' elt = type_expression e state' elt >>? swap in - let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in - let%bind (state', map') = - bind_fold_map_list aux state map in - let aux (x, y) = O.(x.type_expression , y.type_expression) in - let wrapped = Wrap.map (List.map aux map') in - return_wrapped (E_map map') state' wrapped - - (* | E_big_map lst -> - * let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in - * let%bind tv = - * let aux opt c = - * match opt with - * | None -> ok (Some c) - * | Some c' -> - * let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in - * ok (Some c') in - * let%bind key_type = - * let%bind sub = - * bind_fold_list aux None - * @@ List.map get_type_annotation - * @@ List.map fst lst' in - * let%bind annot = bind_map_option get_t_big_map_key tv_opt in - * trace (simple_info "empty map expression without a type annotation") @@ - * O.merge_annotation annot sub (needs_annotation ae "this map literal") - * in - * let%bind value_type = - * let%bind sub = - * bind_fold_list aux None - * @@ List.map get_type_annotation - * @@ List.map snd lst' in - * let%bind annot = bind_map_option get_t_big_map_value tv_opt in - * trace (simple_info "empty map expression without a type annotation") @@ - * O.merge_annotation annot sub (needs_annotation ae "this map literal") - * in - * ok (t_big_map key_type value_type ()) - * in - * return (E_big_map lst') tv *) - | E_big_map big_map -> - let aux' state' elt = type_expression e state' elt >>? swap in - let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in - let%bind (state', big_map') = - bind_fold_map_list aux state big_map in - let aux (x, y) = O.(x.type_expression , y.type_expression) in - let wrapped = Wrap.big_map (List.map aux big_map') in - return_wrapped (E_big_map big_map') state' wrapped - (* | E_lambda { * binder ; * input_type ; @@ -685,17 +554,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - let wrapped = Wrap.application f'.type_expression args.type_expression in return_wrapped (E_application {lamb=f';args}) state'' wrapped - (* | E_look_up dsi -> - * let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - * let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in - * let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in - * return (E_look_up (ds , ind)) (t_option dst ()) *) - - | E_look_up dsi -> - let aux' state' elt = type_expression e state' elt >>? swap in - let%bind (state'' , (ds , ind)) = bind_fold_map_pair aux' state dsi in - let wrapped = Wrap.look_up ds.type_expression ind.type_expression in - return_wrapped (E_look_up (ds , ind)) state'' wrapped (* Advanced *) (* | E_matching (ex, m) -> ( @@ -983,6 +841,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in ok @@ I.TC_big_map (k,v) + | O.TC_map_or_big_map (k,v) -> + let%bind k = untype_type_expression k in + let%bind v = untype_type_expression v in + ok @@ I.TC_map_or_big_map (k,v) | O.TC_arrow ( arg , ret ) -> let%bind arg' = untype_type_expression arg in let%bind ret' = untype_type_expression ret in @@ -1055,30 +917,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind r' = bind_smap @@ Map.String.map untype_expression r in return (e_record r') - | E_record_accessor {expr; label} -> - let%bind r' = untype_expression expr in - let Label s = label in - return (e_accessor r' s) + | E_record_accessor {record; path} -> + let%bind r' = untype_expression record in + let Label s = path in + return (e_record_accessor r' s) | E_record_update {record; path; update} -> let%bind r' = untype_expression record in let%bind e = untype_expression update in let Label l = path in - return (e_update r' l e) - | E_map m -> - let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (e_map m') - | E_big_map m -> - let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (e_big_map m') - | E_list lst -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_list lst') - | E_set lst -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_set lst') - | E_look_up dsi -> - let%bind (a , b) = bind_map_pair untype_expression dsi in - return (e_look_up a b) + return (e_record_update r' l e) | E_matching {matchee;cases} -> let%bind ae' = untype_expression matchee in let%bind m' = untype_matching untype_expression cases in diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 5a11d6184..96137dd56 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -381,6 +381,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_big_map (k,v) + | TC_map_or_big_map (k,v) -> + let%bind k = evaluate_type e k in + let%bind v = evaluate_type e v in + ok @@ O.TC_map_or_big_map (k,v) | TC_arrow ( arg , ret ) -> let%bind arg' = evaluate_type e arg in let%bind ret' = evaluate_type e ret in @@ -450,8 +454,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression return (e_address s) (t_address ()) | E_literal (Literal_operation op) -> return (e_operation op) (t_operation ()) - | E_record_accessor {expr;label} -> - let%bind e' = type_expression' e expr in + | E_record_accessor {record;path} -> + let%bind e' = type_expression' e record in let aux (prev:O.expression) (a:I.label) : O.expression result = let property = a in let%bind r_tv = get_t_record prev.type_expression in @@ -459,10 +463,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression generic_try (bad_record_access property ae prev.type_expression ae.location) @@ (fun () -> I.LMap.find property r_tv) in let location = ae.location in - ok @@ make_a_e ~location (E_record_accessor {expr=prev; label=property}) tv e + ok @@ make_a_e ~location (E_record_accessor {record=prev; path=property}) tv e in let%bind ae = - trace (simple_info "accessing") @@ aux e' label in + trace (simple_info "accessing") @@ aux e' path in (* check type annotation of the final accessed element *) let%bind () = match tv_opt with @@ -511,108 +515,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in return (E_record_update {record; path; update}) wrapped (* Data-structure *) - | E_list lst -> - let%bind lst' = bind_map_list (type_expression' e) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in - ok (Some c') in - let%bind init = match tv_opt with - | None -> ok None - | Some ty -> - let%bind ty' = get_t_list ty in - ok (Some ty') in - let%bind ty = - let%bind opt = bind_fold_list aux init - @@ List.map get_type_expression lst' in - trace_option (needs_annotation ae "empty list") opt in - ok (t_list ty ()) - in - return (E_list lst') tv - | E_set lst -> - let%bind lst' = bind_map_list (type_expression' e) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in - ok (Some c') in - let%bind init = match tv_opt with - | None -> ok None - | Some ty -> - let%bind ty' = get_t_set ty in - ok (Some ty') in - let%bind ty = - let%bind opt = bind_fold_list aux init - @@ List.map get_type_expression lst' in - trace_option (needs_annotation ae "empty set") opt in - ok (t_set ty ()) - in - return (E_set lst') tv - | E_map lst -> - let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in - ok (Some c') in - let%bind key_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_expression - @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_map_key tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - let%bind value_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_expression - @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_map_value tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - ok (t_map key_type value_type ()) - in - return (E_map lst') tv - | E_big_map lst -> - let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in - let%bind tv = - let aux opt c = - match opt with - | None -> ok (Some c) - | Some c' -> - let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in - ok (Some c') in - let%bind key_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_expression - @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_big_map_key tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - let%bind value_type = - let%bind sub = - bind_fold_list aux None - @@ List.map get_type_expression - @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_big_map_value tv_opt in - trace (simple_info "empty map expression without a type annotation") @@ - O.merge_annotation annot sub (needs_annotation ae "this map literal") - in - ok (t_big_map key_type value_type ()) - in - return (E_big_map lst') tv | E_lambda lambda -> let%bind (lambda, lambda_type) = type_lambda e lambda in return (E_lambda lambda ) lambda_type @@ -682,6 +584,35 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let%bind (name', tv) = type_constant cons_name tv_lst tv_opt in return (E_constant {cons_name=name';arguments=lst'}) tv + | E_constant {cons_name=C_SET_ADD|C_CONS as cst;arguments=[key;set]} -> + let%bind key' = type_expression' e key in + let tv_key = get_type_expression key' in + let tv = match tv_opt with + Some tv -> tv + | None -> match cst with + C_SET_ADD -> t_set tv_key () + | C_CONS -> t_list tv_key () + | _ -> failwith "Only C_SET_ADD and C_CONS are possible because those were the two cases matched above" + in + let%bind set' = type_expression' e ~tv_opt:tv set in + let tv_set = get_type_expression set' in + let tv_lst = [tv_key;tv_set] in + let%bind (name', tv) = type_constant cst tv_lst tv_opt in + return (E_constant {cons_name=name';arguments=[key';set']}) tv + | E_constant {cons_name=C_MAP_ADD as cst; arguments=[key;value;map]} -> + let%bind key' = type_expression' e key in + let%bind val' = type_expression' e value in + let tv_key = get_type_expression key' in + let tv_val = get_type_expression val' in + let tv = match tv_opt with + Some tv -> tv + | None -> t_map_or_big_map tv_key tv_val () + in + let%bind map' = type_expression' e ~tv_opt:tv map in + let tv_map = get_type_expression map' in + let tv_lst = [tv_key;tv_val;tv_map] in + let%bind (name', tv) = type_constant cst tv_lst tv_opt in + return (E_constant {cons_name=name';arguments=[key';val';map']}) tv | E_constant {cons_name;arguments} -> let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in let tv_lst = List.map get_type_expression lst' in @@ -703,11 +634,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression lamb'.location in return (E_application {lamb=lamb'; args=args'}) tv - | E_look_up dsi -> - let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in - let%bind _ = O.assert_type_expression_eq (ind.type_expression, src) in - return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) | E_matching {matchee;cases} -> ( let%bind ex' = type_expression' e matchee in @@ -861,30 +787,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind r' = bind_smap @@ Map.String.map untype_expression r in return (e_record r') - | E_record_accessor {expr; label} -> - let%bind r' = untype_expression expr in - let Label s = label in - return (e_accessor r' s) + | E_record_accessor {record; path} -> + let%bind r' = untype_expression record in + let Label s = path in + return (e_record_accessor r' s) | E_record_update {record=r; path=l; update=e} -> let%bind r' = untype_expression r in let%bind e = untype_expression e in let Label l = l in - return (e_update r' l e) - | E_map m -> - let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (e_map m') - | E_big_map m -> - let%bind m' = bind_map_list (bind_map_pair untype_expression) m in - return (e_big_map m') - | E_list lst -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_list lst') - | E_set lst -> - let%bind lst' = bind_map_list untype_expression lst in - return (e_set lst') - | E_look_up dsi -> - let%bind (a , b) = bind_map_pair untype_expression dsi in - return (e_look_up a b) + return (e_record_update r' l e) | E_matching {matchee;cases} -> let%bind ae' = untype_expression matchee in let%bind m' = untype_matching untype_expression cases in diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index 2da8a766e..e410786e9 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -8,17 +8,10 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind init' = f init e in match e.expression_content with | E_literal _ | E_variable _ -> ok init' - | E_list lst | E_set lst | E_constant {arguments=lst} -> ( + | E_constant {arguments=lst} -> ( let%bind res = bind_fold_list self init' lst in ok res ) - | E_map lst | E_big_map lst -> ( - let%bind res = bind_fold_list (bind_fold_pair self) init' lst in - ok res - ) - | E_look_up ab -> - let%bind res = bind_fold_pair self init' ab in - ok res | E_application {lamb; args} -> ( let ab = (lamb, args) in let%bind res = bind_fold_pair self init' ab in @@ -48,8 +41,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = fold_expression self res update in ok res ) - | E_record_accessor {expr} -> ( - let%bind res = self init' expr in + | E_record_accessor {record} -> ( + let%bind res = self init' record in ok res ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( @@ -93,34 +86,14 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind e' = f e in let return expression_content = ok { e' with expression_content } in match e'.expression_content with - | E_list lst -> ( - let%bind lst' = bind_map_list self lst in - return @@ E_list lst' - ) - | E_set lst -> ( - let%bind lst' = bind_map_list self lst in - return @@ E_set lst' - ) - | E_map lst -> ( - let%bind lst' = bind_map_list (bind_map_pair self) lst in - return @@ E_map lst' - ) - | E_big_map lst -> ( - let%bind lst' = bind_map_list (bind_map_pair self) lst in - return @@ E_big_map lst' - ) - | E_look_up ab -> ( - let%bind ab' = bind_map_pair self ab in - return @@ E_look_up ab' - ) | E_matching {matchee=e;cases} -> ( let%bind e' = self e in let%bind cases' = map_cases f cases in return @@ E_matching {matchee=e';cases=cases'} ) - | E_record_accessor acc -> ( - let%bind e' = self acc.expr in - return @@ E_record_accessor {acc with expr = e'} + | E_record_accessor {record; path} -> ( + let%bind record = self record in + return @@ E_record_accessor {record; path} ) | E_record m -> ( let%bind m' = bind_map_lmap self m in @@ -208,34 +181,14 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres else let return expression_content = { e' with expression_content } in match e'.expression_content with - | E_list lst -> ( - let%bind (res, lst') = bind_fold_map_list self init' lst in - ok (res, return @@ E_list lst') - ) - | E_set lst -> ( - let%bind (res, lst') = bind_fold_map_list self init' lst in - ok (res, return @@ E_set lst') - ) - | E_map lst -> ( - let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in - ok (res, return @@ E_map lst') - ) - | E_big_map lst -> ( - let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in - ok (res, return @@ E_big_map lst') - ) - | E_look_up ab -> ( - let%bind (res, ab') = bind_fold_map_pair self init' ab in - ok (res, return @@ E_look_up ab') - ) | E_matching {matchee=e;cases} -> ( let%bind (res, e') = self init' e in let%bind (res,cases') = fold_map_cases f res cases in ok (res, return @@ E_matching {matchee=e';cases=cases'}) ) - | E_record_accessor acc -> ( - let%bind (res, e') = self init' acc.expr in - ok (res, return @@ E_record_accessor {acc with expr = e'}) + | E_record_accessor {record; path} -> ( + let%bind (res, record) = self init' record in + ok (res, return @@ E_record_accessor {record; path}) ) | E_record m -> ( let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in diff --git a/src/passes/9-self_ast_typed/no_nested_big_map.ml b/src/passes/9-self_ast_typed/no_nested_big_map.ml index e1a130ce9..a0b2f869f 100644 --- a/src/passes/9-self_ast_typed/no_nested_big_map.ml +++ b/src/passes/9-self_ast_typed/no_nested_big_map.ml @@ -21,6 +21,10 @@ let rec check_no_nested_bigmap is_in_bigmap e = let%bind _ = check_no_nested_bigmap false key in let%bind _ = check_no_nested_bigmap true value in ok () + | T_operator (TC_map_or_big_map (key, value)) -> + let%bind _ = check_no_nested_bigmap false key in + let%bind _ = check_no_nested_bigmap true value in + ok () | T_operator (TC_contract t) | T_operator (TC_option t) | T_operator (TC_list t) diff --git a/src/passes/9-self_ast_typed/tail_recursion.ml b/src/passes/9-self_ast_typed/tail_recursion.ml index 610484a38..00847e79f 100644 --- a/src/passes/9-self_ast_typed/tail_recursion.ml +++ b/src/passes/9-self_ast_typed/tail_recursion.ml @@ -49,28 +49,13 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit let es = LMap.to_list elm in let%bind _ = bind_map_list (check_recursive_call n false) es in ok () - | E_record_accessor {expr;_} -> - let%bind _ = check_recursive_call n false expr in + | E_record_accessor {record;_} -> + let%bind _ = check_recursive_call n false record in ok () | E_record_update {record;update;_} -> let%bind _ = check_recursive_call n false record in let%bind _ = check_recursive_call n false update in ok () - | E_map eel | E_big_map eel-> - let aux (e1,e2) = - let%bind _ = check_recursive_call n false e1 in - let%bind _ = check_recursive_call n false e2 in - ok () - in - let%bind _ = bind_map_list aux eel in - ok () - | E_list el | E_set el -> - let%bind _ = bind_map_list (check_recursive_call n false) el in - ok () - | E_look_up (e1,e2) -> - let%bind _ = check_recursive_call n false e1 in - let%bind _ = check_recursive_call n false e2 in - ok () and check_recursive_call_in_matching = fun n final_path c -> match c with diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 472b67506..4d9e76d9d 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -621,6 +621,20 @@ module Typer = struct let%bind () = assert_type_expression_eq (src , k) in ok m + let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt -> + match tv_opt with + | None -> simple_fail "untyped MAP_EMPTY" + | Some t -> + let%bind (src, dst) = get_t_map t in + ok @@ t_map src dst () + + let big_map_empty = typer_0 "BIG_MAP_EMPTY" @@ fun tv_opt -> + match tv_opt with + | None -> simple_fail "untyped BIG_MAP_EMPTY" + | Some t -> + let%bind (src, dst) = get_t_big_map t in + ok @@ t_big_map src dst () + let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m -> let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src, k) in @@ -949,6 +963,11 @@ module Typer = struct then ok (t_unit ()) else fail @@ Operator_errors.type_error "bad set iter" key arg () + let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt -> + match tv_opt with + | None -> simple_fail "untyped LIST_EMPTY" + | Some t -> ok t + let list_iter = typer_2 "LIST_ITER" @@ fun body lst -> let%bind (arg , res) = get_t_function body in let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in @@ -1145,7 +1164,6 @@ module Typer = struct | C_SLICE -> ok @@ slice ; | C_BYTES_PACK -> ok @@ bytes_pack ; | C_BYTES_UNPACK -> ok @@ bytes_unpack ; - | C_CONS -> ok @@ cons ; (* SET *) | C_SET_EMPTY -> ok @@ set_empty ; | C_SET_ADD -> ok @@ set_add ; @@ -1155,10 +1173,14 @@ module Typer = struct | C_SET_MEM -> ok @@ set_mem ; (* LIST *) + | C_CONS -> ok @@ cons ; + | C_LIST_EMPTY -> ok @@ list_empty ; | C_LIST_ITER -> ok @@ list_iter ; | C_LIST_MAP -> ok @@ list_map ; | C_LIST_FOLD -> ok @@ list_fold ; (* MAP *) + | C_MAP_EMPTY -> ok @@ map_empty ; + | C_BIG_MAP_EMPTY -> ok @@ big_map_empty ; | C_MAP_ADD -> ok @@ map_add ; | C_MAP_REMOVE -> ok @@ map_remove ; | C_MAP_UPDATE -> ok @@ map_update ; diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index ebb4bd83e..a9ca9fe03 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -4,11 +4,45 @@ open Format open PP_helpers include Stage_common.PP -include Ast_PP_type(Ast_imperative_parameter) let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev +let rec type_expression' : + (formatter -> type_expression -> unit) + -> formatter + -> type_expression + -> unit = + fun f ppf te -> + match te.type_content with + | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m + | T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator f ppf to_ + +and type_expression ppf (te : type_expression) : unit = + type_expression' type_expression ppf te + +and type_operator : + (formatter -> type_expression -> unit) + -> formatter + -> type_operator + -> unit = + fun f ppf to_ -> + let s = + match to_ with + | TC_option te -> Format.asprintf "option(%a)" f te + | TC_list te -> Format.asprintf "list(%a)" f te + | TC_set te -> Format.asprintf "set(%a)" f te + | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v + | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v + | TC_contract te -> Format.asprintf "Contract (%a)" f te + in + fprintf ppf "(TO_%s)" s let rec expression ppf (e : expression) = expression_content ppf e.expression_content @@ -26,11 +60,11 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> - fprintf ppf "%a" (tuple_or_record_sep_expr expression) m + fprintf ppf "{%a}" (record_sep expression (const ";")) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> - fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + fprintf ppf "{ %a with %a = %a }" expression record label path expression update | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m | E_big_map m -> @@ -57,15 +91,58 @@ and expression_content ppf (ec : expression_content) = expression_variable fun_name type_expression fun_type expression_content (E_lambda lambda) - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> - fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result + | E_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_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation + | E_cond {condition; then_clause; else_clause} -> + fprintf ppf "if %a then %a else %a" + expression condition + expression then_clause + expression else_clause | E_sequence {expr1;expr2} -> - fprintf ppf "%a;\n%a" expression expr1 expression expr2 + fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" + | E_tuple t -> + fprintf ppf "(%a)" (list_sep_d expression) t + | E_tuple_accessor ta -> + fprintf ppf "%a.%d" expression ta.tuple ta.path + | E_tuple_update {tuple; path; update} -> + fprintf ppf "{ %a with %d = %a }" expression tuple path expression update + | E_assign {variable; access_path; expression=e} -> + fprintf ppf "%a%a := %a" + expression_variable variable + (list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path + expression e + | E_for {binder; start; final; increment; body} -> + fprintf ppf "for %a from %a to %a by %a do %a" + expression_variable binder + expression start + expression final + expression increment + expression body + | E_for_each {binder; collection; body; _} -> + fprintf ppf "for each %a in %a do %a" + option_map binder + expression collection + expression body + | E_while {condition; body} -> + fprintf ppf "while %a do %a" + expression condition + expression body + +and accessor ppf a = + match a with + | Access_tuple i -> fprintf ppf "%d" i + | Access_record s -> fprintf ppf "%s" s + | Access_map e -> fprintf ppf "%a" expression e + +and option_map ppf (k,v_opt) = + match v_opt with + | None -> fprintf ppf "%a" expression_variable k + | Some v -> fprintf ppf "%a -> %a" expression_variable k expression_variable v and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 92a1dbe73..a71f5268e 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -19,14 +19,9 @@ module Errors = struct end open Errors -let make_t type_content = {type_content; type_meta = ()} +let make_t type_content = {type_content} -let tuple_to_record lst = - let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in - let (_, lst ) = List.fold_left aux (0,[]) lst in - lst - let t_bool : type_expression = make_t @@ T_constant (TC_bool) let t_string : type_expression = make_t @@ T_constant (TC_string) let t_bytes : type_expression = make_t @@ T_constant (TC_bytes) @@ -51,8 +46,8 @@ let t_record m : type_expression = let lst = Map.String.to_kv_list m in t_record_ez lst -let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)] -let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst) +let t_tuple lst : type_expression = make_t @@ T_tuple lst +let t_pair (a , b) : type_expression = t_tuple [a; b] let ez_t_sum (lst:(string * type_expression) list) : type_expression = let aux prev (k, v) = CMap.add (Constructor k) v prev in @@ -118,19 +113,25 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b} +let e_accessor ?loc a b = e_record_accessor ?loc a b let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_skip ?loc () = make_expr ?loc @@ E_skip -let e_let_in ?loc (binder, ascr) mut inline rhs let_result = - make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline } +let e_let_in ?loc (binder, ascr) inline rhs let_result = + make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline } let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b} let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} -let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) + +let e_while ?loc condition body = make_expr ?loc @@ E_while {condition; body} +let e_for ?loc binder start final increment body = make_expr ?loc @@ E_for {binder;start;final;increment;body} +let e_for_each ?loc binder collection collection_type body = make_expr ?loc @@ E_for_each {binder;collection;collection_type;body} + +let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause} (* let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) *) @@ -146,11 +147,12 @@ let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst -let e_update ?loc record path update = +let e_record_update ?loc record path update = let path = Label path in make_expr ?loc @@ E_record_update {record; path; update} +let e_update ?loc record path update = e_record_update ?loc record path update -let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) +let e_tuple ?loc lst : expression = make_expr ?loc @@ E_tuple lst let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let make_option_typed ?loc e t_opt = @@ -163,8 +165,9 @@ let e_typed_none ?loc t_opt = let type_annotation = t_option t_opt in e_annotation ?loc (e_none ?loc ()) type_annotation -let e_typed_list ?loc lst t = - e_annotation ?loc (e_list lst) (t_list t) +let e_typed_list ?loc lst t = e_annotation ?loc (e_list lst) (t_list t) +let e_typed_list_literal ?loc lst t = + e_annotation ?loc (e_constant C_LIST_LITERAL lst) (t_list t) let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v) @@ -186,24 +189,16 @@ let e_lambda ?loc (binder : expression_variable) let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} -let e_assign_with_let ?loc var access_path expr = - let var = Var.of_name (var) in - match access_path with - | [] -> (var, None), true, expr, false - - | lst -> - let rec aux path record= match path with - | [] -> failwith "acces_path cannot be empty" - | [e] -> e_update ?loc record e expr - | elem::tail -> - let next_record = e_accessor record elem in - e_update ?loc record elem (aux tail next_record ) - in - (var, None), true, (aux lst (e_variable var)), false +let e_assign ?loc variable access_path expression = + make_expr ?loc @@ E_assign {variable;access_path;expression} +let e_ez_assign ?loc variable access_path expression = + let variable = Var.of_name variable in + let access_path = List.map (fun s -> Access_record s) access_path in + e_assign ?loc variable access_path expression let get_e_accessor = fun t -> match t with - | E_record_accessor {expr; label} -> ok (expr , label) + | E_record_accessor {record; path} -> ok (record , path) | _ -> simple_fail "not an accessor" let assert_e_accessor = fun t -> @@ -212,14 +207,7 @@ let assert_e_accessor = fun t -> let get_e_pair = fun t -> match t with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> simple_fail "not a pair" - ) + | E_tuple [a ; b] -> ok (a , b) | _ -> simple_fail "not a pair" let get_e_list = fun t -> @@ -227,29 +215,15 @@ let get_e_list = fun t -> | E_list lst -> ok lst | _ -> simple_fail "not a list" -let tuple_of_record (m: _ LMap.t) = - let aux i = - let opt = LMap.find_opt (Label (string_of_int i)) m in - Option.bind (fun opt -> Some (opt,i+1)) opt - in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux - let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ tuple_of_record r + | E_tuple t -> ok @@ t | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" (* Same as get_e_pair *) let extract_pair : expression -> (expression * expression) result = fun e -> match e.expression_content with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> fail @@ bad_kind "pair" e.location - ) + | E_tuple [a;b] -> ok @@ (a,b) | _ -> fail @@ bad_kind "pair" e.location let extract_list : expression -> (expression list) result = fun e -> diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index ca2f2d552..3d0ae94b9 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -86,7 +86,7 @@ val e_variable : ?loc:Location.t -> expression_variable -> expression val e_skip : ?loc:Location.t -> unit -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression -val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression +val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression @@ -100,6 +100,7 @@ val make_option_typed : ?loc:Location.t -> expression -> type_expression option val e_typed_none : ?loc:Location.t -> type_expression -> expression val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression +val e_typed_list_literal : ?loc:Location.t -> expression list -> type_expression -> expression val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression @@ -110,11 +111,15 @@ val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_update : ?loc:Location.t -> expression -> string -> expression -> expression -val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) +val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression +val e_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression (* val get_e_accessor : expression' -> ( expression * access_path ) result *) +val e_while : ?loc:Location.t -> expression -> expression -> expression +val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression +val e_for_each : ?loc:Location.t -> expression_variable * expression_variable option -> expression -> collect_type -> expression -> expression val assert_e_accessor : expression_content -> unit result diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml index 324529525..884822fff 100644 --- a/src/stages/1-ast_imperative/misc.ml +++ b/src/stages/1-ast_imperative/misc.ml @@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | E_record_update _, _ -> simple_fail "comparing record update with other expression" + | E_tuple lsta, E_tuple lstb -> ( + let%bind lst = + generic_try (simple_error "tuples with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_tuple _, _ -> + simple_fail "comparing tuple with other expression" + + | E_tuple_update uta, E_tuple_update utb -> + let _ = + generic_try (simple_error "Updating different tuple") @@ + fun () -> assert_value_eq (uta.tuple, utb.tuple) in + let () = assert (uta.path == utb.path) in + let%bind () = assert_value_eq (uta.update,utb.update) in + ok () + | E_tuple_update _, _ -> + simple_fail "comparing tuple update with other expression" + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (simple_error "maps of different lengths") (fun () -> @@ -182,9 +202,14 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) | (E_variable _, _) | (E_lambda _, _) | (E_application _, _) | (E_let_in _, _) - | (E_recursive _,_) | (E_record_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) - | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" + | (E_recursive _,_) + | (E_record_accessor _, _) | (E_tuple_accessor _, _) + | (E_look_up _, _) + | (E_matching _, _) | (E_cond _, _) + | (E_sequence _, _) | (E_skip, _) + | (E_assign _, _) + | (E_for _, _) | (E_for_each _, _) + | (E_while _, _) -> simple_fail "comparing not a value" let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 4d0d0bd68..6c396fb08 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -2,17 +2,31 @@ module Location = Simple_utils.Location -module Ast_imperative_parameter = struct - type type_meta = unit -end - include Stage_common.Types -(*include Ast_generic_type(Ast_core_parameter) -*) -include Ast_generic_type (Ast_imperative_parameter) +type type_content = + | T_sum of type_expression constructor_map + | T_record of type_expression label_map + | T_tuple of type_expression list + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of type_operator + +and arrow = {type1: type_expression; type2: type_expression} + +and type_operator = + | TC_contract of type_expression + | TC_option of type_expression + | TC_list of type_expression + | TC_set of type_expression + | TC_map of type_expression * type_expression + | TC_big_map of type_expression * type_expression + | TC_arrow of type_expression * type_expression + +and type_expression = {type_content: type_content} + -type inline = bool type program = declaration Location.wrap list and declaration = | Declaration_type of (type_variable * type_expression) @@ -22,7 +36,7 @@ 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 * bool * expression) (* | Macro_declaration of macro_declaration *) and expression = {expression_content: expression_content; location: Location.t} @@ -41,19 +55,28 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update + | E_record_accessor of record_accessor + | E_record_update of record_update (* Advanced *) | E_ascription of ascription (* Sugar *) + | E_cond of conditional | E_sequence of sequence | E_skip + | E_tuple of expression list + | E_tuple_accessor of tuple_accessor + | E_tuple_update of tuple_update (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list | E_list of expression list | E_set of expression list | E_look_up of (expression * expression) + (* Imperative *) + | E_assign of assign + | E_for of for_ + | E_for_each of for_each + | E_while of while_loop and constant = { cons_name: constant' (* this is at the end because it is huge *) @@ -78,16 +101,16 @@ and recursive = { and let_in = { let_binder: expression_variable * type_expression option - ; mut: bool ; rhs: expression ; let_result: expression ; inline: bool } and constructor = {constructor: constructor'; element: expression} -and accessor = {expr: expression; label: label} +and record_accessor = {record: expression; path: label} +and record_update = {record: expression; path: label ; update: expression} + -and update = {record: expression; path: label ; update: expression} and matching_expr = (expr,unit) matching_content and matching = @@ -96,11 +119,57 @@ and matching = } and ascription = {anno_expr: expression; type_annotation: type_expression} + +and conditional = { + condition : expression ; + then_clause : expression ; + else_clause : expression ; +} + and sequence = { expr1: expression ; expr2: expression ; } +and tuple_accessor = {tuple: expression; path: int} +and tuple_update = {tuple: expression; path: int ; update: expression} + +and assign = { + variable : expression_variable; + access_path : access list; + expression : expression; +} + +and access = + | Access_tuple of int + | Access_record of string + | Access_map of expr + +and for_ = { + binder : expression_variable; + start : expression; + final : expression; + increment : expression; + body : expression; +} + +and for_each = { + binder : expression_variable * expression_variable option; + collection : expression; + collection_type : collect_type; + body : expression; +} + +and collect_type = + | Map + | Set + | List + +and while_loop = { + condition : expression; + body : expression; +} + and environment_element_definition = | ED_binder | ED_declaration of (expression * free_variables) diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index d4a4ead08..b57e65bcb 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -4,11 +4,41 @@ open Format open PP_helpers include Stage_common.PP -include Ast_PP_type(Ast_sugar_parameter) let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev +let rec type_expression' : + (formatter -> type_expression -> unit) + -> formatter + -> type_expression + -> unit = + fun f ppf te -> + match te.type_content with + | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m + | T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator f ppf to_ + +and type_expression ppf (te : type_expression) : unit = + type_expression' type_expression ppf te + +and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit = + fun f ppf to_ -> + let s = + match to_ with + | TC_option te -> Format.asprintf "option(%a)" f te + | TC_list te -> Format.asprintf "list(%a)" f te + | TC_set te -> Format.asprintf "set(%a)" f te + | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v + | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v + | TC_contract te -> Format.asprintf "Contract (%a)" f te + in + fprintf ppf "(TO_%s)" s let rec expression ppf (e : expression) = expression_content ppf e.expression_content @@ -26,11 +56,11 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> - fprintf ppf "%a" (tuple_or_record_sep_expr expression) m + fprintf ppf "{%a}" (record_sep expression (const ";")) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> - fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + fprintf ppf "{ %a with %a = %a }" expression record label path expression update | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m | E_big_map m -> @@ -56,14 +86,30 @@ and expression_content ppf (ec : expression_content) = | E_matching {matchee; cases; _} -> fprintf ppf "match %a with %a" expression matchee (matching expression) cases - | 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_sequence {expr1;expr2} -> - fprintf ppf "%a;\n%a" expression expr1 expression expr2 + | E_let_in { let_binder ; rhs ; let_result; inline; mut} -> + fprintf ppf "let %a%a = %a%a in %a" + option_type_name let_binder + option_mut mut + expression rhs + option_inline inline + expression let_result | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation + | E_cond {condition; then_clause; else_clause} -> + fprintf ppf "if %a then %a else %a" + expression condition + expression then_clause + expression else_clause + | E_sequence {expr1;expr2} -> + fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" + | E_tuple t -> + fprintf ppf "(%a)" (list_sep_d expression) t + | E_tuple_accessor ta -> + fprintf ppf "%a.%d" expression ta.tuple ta.path + | E_tuple_update {tuple; path; update} -> + fprintf ppf "{ %a with %d = %a }" expression tuple path expression update and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 759d6fc55..4edfc377f 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -19,7 +19,7 @@ module Errors = struct end open Errors -let make_t type_content = {type_content; type_meta = ()} +let make_t type_content = {type_content} let tuple_to_record lst = @@ -107,33 +107,31 @@ let e_bytes_raw ?loc (b: bytes) : expression = make_expr ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) -let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []} -let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} -let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} -let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst -let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst -let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} -let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b} +let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v -let e_skip ?loc () = make_expr ?loc @@ E_skip -let e_let_in ?loc (binder, ascr) inline rhs let_result = - make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline } -let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_let_in ?loc (binder, ascr) mut inline rhs let_result = + make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut } let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b} -let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} -let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) + +let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} + +let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause} let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} -let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) -(* -let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) -*) +let e_skip ?loc () = make_expr ?loc @@ E_skip + +let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst +let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst +let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst +let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst +let e_look_up ?loc a b : expression = make_expr ?loc @@ E_look_up (a,b) + let ez_match_variant (lst : ((string * string) * 'a) list) = let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in Match_variant (lst,()) @@ -145,19 +143,19 @@ let e_record_ez ?loc (lst : (string * expr) list) : expression = let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path= Label b} -let e_update ?loc record path update = +let e_record_update ?loc record path update = let path = Label path in make_expr ?loc @@ E_record_update {record; path; update} -let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) -let e_pair ?loc a b : expression = e_tuple ?loc [a;b] - let make_option_typed ?loc e t_opt = match t_opt with | None -> e | Some t -> e_annotation ?loc e t +let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) +let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_typed_none ?loc t_opt = let type_annotation = t_option t_opt in @@ -185,41 +183,18 @@ let e_lambda ?loc (binder : expression_variable) } let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} - -let e_assign_with_let ?loc var access_path expr = - let var = Var.of_name (var) in - match access_path with - | [] -> (var, None), true, expr, false - - | lst -> - let rec aux path record= match path with - | [] -> failwith "acces_path cannot be empty" - | [e] -> e_update ?loc record e expr - | elem::tail -> - let next_record = e_accessor record elem in - e_update ?loc record elem (aux tail next_record ) - in - (var, None), true, (aux lst (e_variable var)), false - -let get_e_accessor = fun t -> +let get_e_record_accessor = fun t -> match t with - | E_record_accessor {expr; label} -> ok (expr , label) - | _ -> simple_fail "not an accessor" + | E_record_accessor {record; path} -> ok (record, path) + | _ -> simple_fail "not a record accessor" let assert_e_accessor = fun t -> - let%bind _ = get_e_accessor t in + let%bind _ = get_e_record_accessor t in ok () let get_e_pair = fun t -> match t with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> simple_fail "not a pair" - ) + | E_tuple [a ; b] -> ok (a , b) | _ -> simple_fail "not a pair" let get_e_list = fun t -> @@ -227,29 +202,15 @@ let get_e_list = fun t -> | E_list lst -> ok lst | _ -> simple_fail "not a list" -let tuple_of_record (m: _ LMap.t) = - let aux i = - let opt = LMap.find_opt (Label (string_of_int i)) m in - Option.bind (fun opt -> Some (opt,i+1)) opt - in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux - let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ tuple_of_record r + | E_tuple t -> ok @@ t | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" (* Same as get_e_pair *) let extract_pair : expression -> (expression * expression) result = fun e -> match e.expression_content with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> fail @@ bad_kind "pair" e.location - ) + | E_tuple [a;b] -> ok @@ (a,b) | _ -> fail @@ bad_kind "pair" e.location let extract_list : expression -> (expression list) result = fun e -> diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index e9d3dd144..1fa10df89 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -65,33 +65,37 @@ val e'_bytes : string -> expression_content result val e_bytes_hex : ?loc:Location.t -> string -> expression result val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_string : ?loc:Location.t -> string -> expression -val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression - -val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression -val e_tuple : ?loc:Location.t -> expression list -> expression val e_some : ?loc:Location.t -> expression -> expression val e_none : ?loc:Location.t -> unit -> expression -val e_string_cat : ?loc:Location.t -> expression -> expression -> expression -val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression -val e_set : ?loc:Location.t -> expression list -> expression -val e_list : ?loc:Location.t -> expression list -> expression -val e_pair : ?loc:Location.t -> expression -> expression -> expression + +val e_variable : ?loc:Location.t -> expression_variable -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression +val e_constant : ?loc:Location.t -> constant' -> expression list -> expression + +val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression +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_record : ?loc:Location.t -> expr Map.String.t -> expression +val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression +val e_record_accessor : ?loc:Location.t -> expression -> string -> expression +val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression + +val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression + +val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression +val e_sequence : ?loc:Location.t -> expression -> expression -> expression +val e_skip : ?loc:Location.t -> unit -> expression + +val e_list : ?loc:Location.t -> expression list -> expression +val e_set : ?loc:Location.t -> expression list -> expression +val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression +val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression +val e_look_up : ?loc:Location.t -> expression -> expression -> expression + val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_accessor : ?loc:Location.t -> expression -> string -> expression -val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression -val e_variable : ?loc:Location.t -> expression_variable -> expression -val e_skip : ?loc:Location.t -> unit -> expression -val e_sequence : ?loc:Location.t -> expression -> expression -> expression -val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression -val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression -val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression -val e_application : ?loc:Location.t -> expression -> expression -> expression -val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression -val e_constant : ?loc:Location.t -> constant' -> expression list -> expression -val e_look_up : ?loc:Location.t -> expression -> expression -> expression val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression @@ -103,18 +107,11 @@ val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expr val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression - val e_typed_set : ?loc:Location.t -> expression list -> type_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_record : ?loc:Location.t -> expr Map.String.t -> expression -val e_update : ?loc:Location.t -> expression -> string -> expression -> expression -val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) - -(* -val get_e_accessor : expression' -> ( expression * access_path ) result -*) +val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression +val e_tuple : ?loc:Location.t -> expression list -> expression +val e_pair : ?loc:Location.t -> expression -> expression -> expression val assert_e_accessor : expression_content -> unit result diff --git a/src/stages/2-ast_sugar/misc.ml b/src/stages/2-ast_sugar/misc.ml index 324529525..508ae70d9 100644 --- a/src/stages/2-ast_sugar/misc.ml +++ b/src/stages/2-ast_sugar/misc.ml @@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | E_record_update _, _ -> simple_fail "comparing record update with other expression" + | E_tuple lsta, E_tuple lstb -> ( + let%bind lst = + generic_try (simple_error "tuples with different number of elements") + (fun () -> List.combine lsta lstb) in + let%bind _all = bind_list @@ List.map assert_value_eq lst in + ok () + ) + | E_tuple _, _ -> + simple_fail "comparing tuple with other expression" + + | E_tuple_update uta, E_tuple_update utb -> + let _ = + generic_try (simple_error "Updating different tuple") @@ + fun () -> assert_value_eq (uta.tuple, utb.tuple) in + let () = assert (uta.path == utb.path) in + let%bind () = assert_value_eq (uta.update,utb.update) in + ok () + | E_tuple_update _, _ -> + simple_fail "comparing tuple update with other expression" + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (simple_error "maps of different lengths") (fun () -> @@ -182,8 +202,10 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) | (E_variable _, _) | (E_lambda _, _) | (E_application _, _) | (E_let_in _, _) - | (E_recursive _,_) | (E_record_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) + | (E_recursive _,_) + | (E_record_accessor _, _) | (E_tuple_accessor _, _) + | (E_look_up _, _) + | (E_matching _, _) | (E_cond _, _) | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 81091dea7..cd648c754 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -2,17 +2,31 @@ module Location = Simple_utils.Location -module Ast_sugar_parameter = struct - type type_meta = unit -end - include Stage_common.Types -(*include Ast_generic_type(Ast_core_parameter) -*) -include Ast_generic_type (Ast_sugar_parameter) +type type_content = + | T_sum of type_expression constructor_map + | T_record of type_expression label_map + | T_tuple of type_expression list + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of type_operator + +and arrow = {type1: type_expression; type2: type_expression} + +and type_operator = + | TC_contract of type_expression + | TC_option of type_expression + | TC_list of type_expression + | TC_set of type_expression + | TC_map of type_expression * type_expression + | TC_big_map of type_expression * type_expression + | TC_arrow of type_expression * type_expression + +and type_expression = {type_content: type_content} + -type inline = bool type program = declaration Location.wrap list and declaration = | Declaration_type of (type_variable * type_expression) @@ -22,7 +36,7 @@ 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 * bool * expression) (* | Macro_declaration of macro_declaration *) and expression = {expression_content: expression_content; location: Location.t} @@ -41,13 +55,17 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update + | E_record_accessor of record_accessor + | E_record_update of record_update (* Advanced *) | E_ascription of ascription (* Sugar *) + | E_cond of conditional | E_sequence of sequence | E_skip + | E_tuple of expression list + | E_tuple_accessor of tuple_accessor + | E_tuple_update of tuple_update (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -76,17 +94,18 @@ and recursive = { lambda : lambda; } -and let_in = - { let_binder: expression_variable * type_expression option - ; rhs: expression - ; let_result: expression - ; inline: bool } +and let_in = { + let_binder: expression_variable * type_expression option ; + rhs: expression ; + let_result: expression ; + inline: bool ; + mut: bool; + } and constructor = {constructor: constructor'; element: expression} -and accessor = {expr: expression; label: label} - -and update = {record: expression; path: label ; update: expression} +and record_accessor = {record: expression; path: label} +and record_update = {record: expression; path: label ; update: expression} and matching_expr = (expr,unit) matching_content and matching = @@ -95,11 +114,20 @@ and matching = } and ascription = {anno_expr: expression; type_annotation: type_expression} + +and conditional = { + condition : expression ; + then_clause : expression ; + else_clause : expression ; +} and sequence = { expr1: expression ; expr2: expression ; } +and tuple_accessor = {tuple: expression; path: int} +and tuple_update = {tuple: expression; path: int ; update: expression} + and environment_element_definition = | ED_binder | ED_declaration of (expression * free_variables) diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index 3410a96fb..2909d4dc8 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -28,19 +28,9 @@ and expression_content ppf (ec : expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update - | E_map m -> - fprintf ppf "map[%a]" (list_sep_d assoc_expression) m - | E_big_map m -> - fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m - | E_list lst -> - fprintf ppf "list[%a]" (list_sep_d expression) lst - | E_set lst -> - fprintf ppf "set[%a]" (list_sep_d expression) lst - | E_look_up (ds, ind) -> - fprintf ppf "(%a)[%a]" expression ds expression ind | E_lambda {binder; input_type; output_type; result} -> fprintf ppf "lambda (%a:%a) : %a return %a" expression_variable binder diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index db2417902..f5f5f103b 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -107,19 +107,15 @@ let e_bytes_raw ?loc (b: bytes) : expression = make_expr ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) -let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []} let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} -let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst -let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst -let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} -let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b} +let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_let_in ?loc (binder, ascr) inline rhs let_result = make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } @@ -127,7 +123,6 @@ let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b} let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} -let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) (* let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) @@ -144,7 +139,7 @@ let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst -let e_update ?loc record path update = +let e_record_update ?loc record path update = let path = Label path in make_expr ?loc @@ E_record_update {record; path; update} @@ -161,15 +156,6 @@ let e_typed_none ?loc t_opt = let type_annotation = t_option t_opt in e_annotation ?loc (e_none ?loc ()) type_annotation -let e_typed_list ?loc lst t = - e_annotation ?loc (e_list lst) (t_list t) - -let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) -let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v) - -let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) - - let e_lambda ?loc (binder : expression_variable) (input_type : type_expression option) (output_type : type_expression option) @@ -192,20 +178,20 @@ let e_assign_with_let ?loc var access_path expr = | lst -> let rec aux path record= match path with | [] -> failwith "acces_path cannot be empty" - | [e] -> e_update ?loc record e expr + | [e] -> e_record_update ?loc record e expr | elem::tail -> - let next_record = e_accessor record elem in - e_update ?loc record elem (aux tail next_record ) + let next_record = e_record_accessor record elem in + e_record_update ?loc record elem (aux tail next_record ) in (var, None), true, (aux lst (e_variable var)), false -let get_e_accessor = fun t -> +let get_e_record_accessor = fun t -> match t with - | E_record_accessor {expr; label} -> ok (expr , label) + | E_record_accessor {record; path} -> ok (record, path) | _ -> simple_fail "not an accessor" -let assert_e_accessor = fun t -> - let%bind _ = get_e_accessor t in +let assert_e_record_accessor = fun t -> + let%bind _ = get_e_record_accessor t in ok () let get_e_pair = fun t -> @@ -221,20 +207,20 @@ let get_e_pair = fun t -> | _ -> simple_fail "not a pair" let get_e_list = fun t -> - match t with - | E_list lst -> ok lst - | _ -> simple_fail "not a list" - -let tuple_of_record (m: _ LMap.t) = - let aux i = - let opt = LMap.find_opt (Label (string_of_int i)) m in - Option.bind (fun opt -> Some (opt,i+1)) opt + let rec aux t = + match t with + E_constant {cons_name=C_CONS;arguments=[key;lst]} -> + let%bind lst = aux lst.expression_content in + ok @@ key::(lst) + | E_constant {cons_name=C_LIST_EMPTY;arguments=[]} -> + ok @@ [] + | _ -> simple_fail "not a list" in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux + aux t let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ tuple_of_record r + | E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" (* Same as get_e_pair *) @@ -250,17 +236,18 @@ let extract_pair : expression -> (expression * expression) result = fun e -> ) | _ -> fail @@ bad_kind "pair" e.location -let extract_list : expression -> (expression list) result = fun e -> - match e.expression_content with - | E_list lst -> ok lst - | _ -> fail @@ bad_kind "list" e.location - let extract_record : expression -> (label * expression) list result = fun e -> match e.expression_content with | E_record lst -> ok @@ LMap.to_kv_list lst | _ -> fail @@ bad_kind "record" e.location let extract_map : expression -> (expression * expression) list result = fun e -> - match e.expression_content with - | E_map lst -> ok lst - | _ -> fail @@ bad_kind "map" e.location + let rec aux e = + match e.expression_content with + E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} -> + let%bind map = aux map in + ok @@ (k,v)::map + | E_constant {cons_name=C_MAP_EMPTY|C_BIG_MAP_EMPTY; arguments=[]} -> ok @@ [] + | _ -> fail @@ bad_kind "map" e.location + in + aux e diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index ae0aab1bd..e09ede186 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -65,7 +65,6 @@ val e'_bytes : string -> expression_content result val e_bytes_hex : ?loc:Location.t -> string -> expression result val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_string : ?loc:Location.t -> string -> expression -val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression val e_tuple : ?loc:Location.t -> expression list -> expression @@ -73,15 +72,12 @@ val e_some : ?loc:Location.t -> expression -> expression val e_none : ?loc:Location.t -> unit -> expression val e_string_cat : ?loc:Location.t -> expression -> expression -> expression val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression -val e_set : ?loc:Location.t -> expression list -> expression -val e_list : ?loc:Location.t -> expression list -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_accessor : ?loc:Location.t -> expression -> string -> expression -val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression +val e_record_accessor : ?loc:Location.t -> expression -> string -> expression +val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression @@ -89,7 +85,6 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_application : ?loc:Location.t -> expression -> expression -> expression val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression val e_constant : ?loc:Location.t -> constant' -> expression list -> expression -val e_look_up : ?loc:Location.t -> expression -> expression -> expression val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression @@ -97,24 +92,17 @@ val make_option_typed : ?loc:Location.t -> expression -> type_expression option val e_typed_none : ?loc:Location.t -> type_expression -> expression -val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression - -val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression -val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression - -val e_typed_set : ?loc:Location.t -> expression list -> type_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_record : ?loc:Location.t -> expr Map.String.t -> expression -val e_update : ?loc:Location.t -> expression -> string -> expression -> expression +val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) (* val get_e_accessor : expression' -> ( expression * access_path ) result *) -val assert_e_accessor : expression_content -> unit result +val assert_e_record_accessor : expression_content -> unit result val get_e_pair : expression_content -> ( expression * expression ) result @@ -126,8 +114,6 @@ val is_e_failwith : expression -> bool *) val extract_pair : expression -> ( expression * expression ) result -val extract_list : expression -> (expression list) result - val extract_record : expression -> (label * expression) list result val extract_map : expression -> (expression * expression) list result diff --git a/src/stages/3-ast_core/misc.ml b/src/stages/3-ast_core/misc.ml index a09efa475..ad38b9fec 100644 --- a/src/stages/3-ast_core/misc.ml +++ b/src/stages/3-ast_core/misc.ml @@ -139,52 +139,13 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ok () | E_record_update _, _ -> simple_fail "comparing record update with other expression" - - | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( - let%bind lst = generic_try (simple_error "maps of different lengths") - (fun () -> - let lsta' = List.sort compare lsta in - let lstb' = List.sort compare lstb in - List.combine lsta' lstb') in - let aux = fun ((ka, va), (kb, vb)) -> - let%bind _ = assert_value_eq (ka, kb) in - let%bind _ = assert_value_eq (va, vb) in - ok () in - let%bind _all = bind_map_list aux lst in - ok () - ) - | (E_map _ | E_big_map _), _ -> - simple_fail "comparing map with other expression" - - | E_list lsta, E_list lstb -> ( - let%bind lst = - generic_try (simple_error "list of different lengths") - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_list _, _ -> - simple_fail "comparing list with other expression" - - | E_set lsta, E_set lstb -> ( - let lsta' = List.sort (compare) lsta in - let lstb' = List.sort (compare) lstb in - let%bind lst = - generic_try (simple_error "set of different lengths") - (fun () -> List.combine lsta' lstb') in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_set _, _ -> - simple_fail "comparing set with other expression" - | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b) | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) | (E_variable _, _) | (E_lambda _, _) | (E_application _, _) | (E_let_in _, _) | (E_recursive _,_) | (E_record_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) - -> simple_fail "comparing not a value" + | (E_matching _, _) + -> simple_fail "comparing not a value" let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) diff --git a/src/stages/3-ast_core/types.ml b/src/stages/3-ast_core/types.ml index 2b8f0dbc2..6c9637ac4 100644 --- a/src/stages/3-ast_core/types.ml +++ b/src/stages/3-ast_core/types.ml @@ -41,15 +41,8 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update - (* Data Structures *) - (* TODO : move to constant*) - | E_map of (expression * expression) list (*move to operator *) - | E_big_map of (expression * expression) list (*move to operator *) - | E_list of expression list - | E_set of expression list - | E_look_up of (expression * expression) + | E_record_accessor of record_accessor + | E_record_update of record_update (* Advanced *) | E_ascription of ascription @@ -82,9 +75,8 @@ and let_in = and constructor = {constructor: constructor'; element: expression} -and accessor = {expr: expression; label: label} - -and update = {record: expression; path: label ; update: expression} +and record_accessor = {record: expression; path: label} +and record_update = {record: expression; path: label ; update: expression} and matching_expr = (expr,unit) matching_content and matching = diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 1325d0476..0f1722641 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -29,19 +29,9 @@ and expression_content ppf (ec: expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update - | E_map m -> - fprintf ppf "map[%a]" (list_sep_d assoc_expression) m - | E_big_map m -> - fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m - | E_list lst -> - fprintf ppf "list[%a]" (list_sep_d expression) lst - | E_set lst -> - fprintf ppf "set[%a]" (list_sep_d expression) lst - | E_look_up (ds, ind) -> - fprintf ppf "(%a)[%a]" expression ds expression ind | E_lambda {binder; result} -> fprintf ppf "lambda (%a) return %a" expression_variable binder expression result diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 014ab8f2f..8f4aaac2a 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -64,6 +64,7 @@ let t_pair a b ?s () : type_expression = ez_t_record [(Label "0",a) ; (Label " let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s +let t_map_or_big_map key value ?s () = make_t (T_operator (TC_map_or_big_map (key,value))) s let t_sum m ?s () : type_expression = make_t (T_sum m) s let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression = @@ -190,11 +191,13 @@ let get_t_record (t:type_expression) : type_expression label_map result = match let get_t_map (t:type_expression) : (type_expression * type_expression) result = match t.type_content with | T_operator (TC_map (k,v)) -> ok (k, v) + | T_operator (TC_map_or_big_map (k,v)) -> ok (k, v) | _ -> fail @@ Errors.not_a_x_type "map" t () let get_t_big_map (t:type_expression) : (type_expression * type_expression) result = match t.type_content with | T_operator (TC_big_map (k,v)) -> ok (k, v) + | T_operator (TC_map_or_big_map (k,v)) -> ok (k, v) | _ -> fail @@ Errors.not_a_x_type "big_map" t () let get_t_map_key : type_expression -> type_expression result = fun t -> @@ -276,8 +279,6 @@ let ez_e_record (lst : (label * expression) list) : expression_content = let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]} let e_none (): expression_content = E_constant {cons_name=C_NONE; arguments=[]} -let e_map lst : expression_content = E_map lst - let e_unit () : expression_content = E_literal (Literal_unit) let e_int n : expression_content = E_literal (Literal_int n) let e_nat n : expression_content = E_literal (Literal_nat n) @@ -296,7 +297,6 @@ let e_lambda l : expression_content = E_lambda l let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)] let e_application lamb args : expression_content = E_application {lamb;args} let e_variable v : expression_content = E_variable v -let e_list lst : expression_content = E_list lst let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline } let e_a_unit = make_a_e (e_unit ()) (t_unit ()) @@ -314,8 +314,6 @@ let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_expression let e_a_application a b = make_a_e (e_application a b) (get_type_expression b) let e_a_variable v ty = make_a_e (e_variable v) ty let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ()) -let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ()) -let e_a_list lst t = make_a_e (e_list lst) (t_list t ()) let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_expression body) @@ -337,7 +335,7 @@ let get_a_bool (t:expression) = let get_a_record_accessor = fun t -> match t.expression_content with - | E_record_accessor {expr ; label} -> ok (expr , label) + | E_record_accessor {record; path} -> ok (record, path) | _ -> simple_fail "not an accessor" let get_declaration_by_name : program -> string -> declaration result = fun p name -> diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index a42abd3cc..fadef09e3 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -31,6 +31,7 @@ val ez_t_record : ( label * type_expression ) list -> ?s:S.type_expression -> un val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression +val t_map_or_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression @@ -109,7 +110,6 @@ val ez_e_record : ( string * expression ) list -> expression *) val e_some : expression -> expression_content val e_none : unit -> expression_content -val e_map : ( expression * expression ) list -> expression_content val e_unit : unit -> expression_content val e_int : int -> expression_content val e_nat : int -> expression_content @@ -128,7 +128,6 @@ val e_lambda : lambda -> expression_content val e_pair : expression -> expression -> expression_content val e_application : expression -> expr -> expression_content val e_variable : expression_variable -> expression_content -val e_list : expression list -> expression_content val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content val e_a_unit : full_environment -> expression @@ -146,8 +145,6 @@ val e_a_record : expression label_map -> full_environment -> expression val e_a_application : expression -> expression -> full_environment -> expression val e_a_variable : expression_variable -> type_expression -> full_environment -> expression val ez_e_a_record : ( label * expression ) list -> full_environment -> expression -val e_a_map : ( expression * expression ) list -> type_expression -> type_expression -> full_environment -> expression -val e_a_list : expression list -> type_expression -> full_environment -> expression val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression val get_a_int : expression -> int result diff --git a/src/stages/4-ast_typed/combinators_environment.ml b/src/stages/4-ast_typed/combinators_environment.ml index f92ef3aea..f73c2b305 100644 --- a/src/stages/4-ast_typed/combinators_environment.ml +++ b/src/stages/4-ast_typed/combinators_environment.ml @@ -14,8 +14,6 @@ let e_a_empty_pair a b = e_a_pair a b Environment.full_empty let e_a_empty_some s = e_a_some s Environment.full_empty let e_a_empty_none t = e_a_none t Environment.full_empty let e_a_empty_record r = e_a_record r Environment.full_empty -let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty -let e_a_empty_list lst t = e_a_list lst t Environment.full_empty let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty diff --git a/src/stages/4-ast_typed/combinators_environment.mli b/src/stages/4-ast_typed/combinators_environment.mli index da4b2cfb9..830ac7ee2 100644 --- a/src/stages/4-ast_typed/combinators_environment.mli +++ b/src/stages/4-ast_typed/combinators_environment.mli @@ -13,8 +13,6 @@ val e_a_empty_pair : expression -> expression -> expression val e_a_empty_some : expression -> expression val e_a_empty_none : type_expression -> expression val e_a_empty_record : expression label_map -> expression -val e_a_empty_map : (expression * expression ) list -> type_expression -> type_expression -> expression -val e_a_empty_list : expression list -> type_expression -> expression val ez_e_a_empty_record : ( label * expression ) list -> expression val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 04efcca5f..8f6158109 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -209,12 +209,8 @@ module Free_variables = struct | E_application {lamb;args} -> unions @@ List.map self [ lamb ; args ] | E_constructor {element;_} -> self element | E_record m -> unions @@ List.map self @@ LMap.to_list m - | E_record_accessor {expr;_} -> self expr + | E_record_accessor {record;_} -> self record | E_record_update {record; update;_} -> union (self record) @@ self update - | E_list lst -> unions @@ List.map self lst - | E_set lst -> unions @@ List.map self lst - | (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m - | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] | E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases) | E_let_in { let_binder; rhs; let_result; _} -> let b' = union (singleton let_binder) b in @@ -342,10 +338,11 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : | TC_list la, TC_list lb | TC_contract la, TC_contract lb | TC_set la, TC_set lb -> ok @@ ([la], [lb]) - | TC_map (ka,va), TC_map (kb,vb) - | TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb]) - | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _), - (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb + | (TC_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_map (kb,vb) | TC_map_or_big_map (kb,vb)) + | (TC_big_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_big_map (kb,vb) | TC_map_or_big_map (kb,vb)) + -> ok @@ ([ka;va] ,[kb;vb]) + | (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _), + (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb in if List.length lsta <> List.length lstb then fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) @@ -497,44 +494,10 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result = | E_record _, _ -> fail @@ (different_values_because_different_types "record vs. non-record" a b) - | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( - let%bind lst = generic_try (different_size_values "maps of different lengths" a b) - (fun () -> - let lsta' = List.sort compare lsta in - let lstb' = List.sort compare lstb in - List.combine lsta' lstb') in - let aux = fun ((ka, va), (kb, vb)) -> - let%bind _ = assert_value_eq (ka, kb) in - let%bind _ = assert_value_eq (va, vb) in - ok () in - let%bind _all = bind_map_list aux lst in - ok () - ) - | (E_map _ | E_big_map _), _ -> - fail @@ different_values_because_different_types "map vs. non-map" a b - - | E_list lsta, E_list lstb -> ( - let%bind lst = - generic_try (different_size_values "lists of different lengths" a b) - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_list _, _ -> - fail @@ different_values_because_different_types "list vs. non-list" a b - | E_set lsta, E_set lstb -> ( - let%bind lst = - generic_try (different_size_values "sets of different lengths" a b) - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_set _, _ -> - fail @@ different_values_because_different_types "set vs. non-set" a b | (E_literal _, _) | (E_variable _, _) | (E_application _, _) | (E_lambda _, _) | (E_let_in _, _) | (E_recursive _, _) | (E_record_accessor _, _) | (E_record_update _,_) - | (E_look_up _, _) | (E_matching _, _) + | (E_matching _, _) -> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result = diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 0040f7d90..b4a0b5095 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -70,23 +70,11 @@ module Captured_variables = struct | E_record m -> let%bind lst' = bind_map_list self @@ LMap.to_list m in ok @@ unions lst' - | E_record_accessor {expr;_} -> self expr + | E_record_accessor {record;_} -> self record | E_record_update {record;update;_} -> let%bind r = self record in let%bind e = self update in ok @@ union r e - | E_list lst -> - let%bind lst' = bind_map_list self lst in - ok @@ unions lst' - | E_set lst -> - let%bind lst' = bind_map_list self lst in - ok @@ unions lst' - | (E_map m | E_big_map m) -> - let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in - ok @@ unions lst' - | E_look_up (a , b) -> - let%bind lst' = bind_map_list self [ a ; b ] in - ok @@ unions lst' | E_matching {matchee;cases;_} -> let%bind a' = self matchee in let%bind cs' = matching_expression b cases in diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index fdb24969b..b406c46b7 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -47,15 +47,8 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update - (* Data Structures *) - (* TODO : move to constant*) - | E_map of (expression * expression) list (*move to operator *) - | E_big_map of (expression * expression) list (*move to operator *) - | E_list of expression list - | E_set of expression list - | E_look_up of (expression * expression) + | E_record_accessor of record_accessor + | E_record_update of record_update and constant = { cons_name: constant' @@ -91,12 +84,12 @@ and constructor = { element: expression ; } -and accessor = { - expr: expression ; - label: label ; +and record_accessor = { + record: expression ; + path: label ; } -and update = { +and record_update = { record: expression ; path: label ; update: expression ; diff --git a/src/stages/5-mini_c/PP.ml b/src/stages/5-mini_c/PP.ml index dfbbfdd64..808b65873 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -86,10 +86,6 @@ and expression' ppf (e:expression') = match e with | E_constant c -> fprintf ppf "%a %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments | E_literal v -> fprintf ppf "L(%a)" value v - | E_make_empty_map _ -> fprintf ppf "map[]" - | E_make_empty_big_map _ -> fprintf ppf "big_map[]" - | E_make_empty_list _ -> fprintf ppf "list[]" - | E_make_empty_set _ -> fprintf ppf "set[]" | E_make_none _ -> fprintf ppf "none" | E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s @@ -199,6 +195,8 @@ and constant ppf : constant' -> unit = function | C_SET_FOLD -> fprintf ppf "SET_FOLD" | C_SET_MEM -> fprintf ppf "SET_MEM" (* List *) + | C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY" + | C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL" | C_LIST_ITER -> fprintf ppf "LIST_ITER" | C_LIST_MAP -> fprintf ppf "LIST_MAP" | C_LIST_FOLD -> fprintf ppf "LIST_FOLD" diff --git a/src/stages/5-mini_c/misc.ml b/src/stages/5-mini_c/misc.ml index 31c816178..5aef14523 100644 --- a/src/stages/5-mini_c/misc.ml +++ b/src/stages/5-mini_c/misc.ml @@ -44,10 +44,6 @@ module Free_variables = struct | E_constant (c) -> unions @@ List.map self c.arguments | E_application (f, x) -> unions @@ [ self f ; self x ] | E_variable n -> var_name b n - | E_make_empty_map _ -> empty - | E_make_empty_big_map _ -> empty - | E_make_empty_list _ -> empty - | E_make_empty_set _ -> empty | E_make_none _ -> empty | E_iterator (_, ((v, _), body), expr) -> unions [ expression (union (singleton v) b) body ; diff --git a/src/stages/5-mini_c/types.ml b/src/stages/5-mini_c/types.ml index b1e419b8b..8461df787 100644 --- a/src/stages/5-mini_c/types.ml +++ b/src/stages/5-mini_c/types.ml @@ -59,10 +59,6 @@ and expression' = | E_constant of constant | E_application of (expression * expression) | E_variable of var_name - | E_make_empty_map of (type_value * type_value) - | E_make_empty_big_map of (type_value * type_value) - | E_make_empty_list of type_value - | E_make_empty_set of type_value | E_make_none of type_value | E_iterator of constant' * ((var_name * type_value) * expression) * expression | E_fold of (((var_name * type_value) * expression) * expression * expression) diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index c3557f3d5..832609b47 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -16,15 +16,14 @@ let cmap_sep value sep ppf m = let record_sep value sep ppf (m : 'a label_map) = let lst = LMap.to_kv_list m in - let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in + let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let tuple_sep value sep ppf m = assert (Helpers.is_tuple_lmap m); - let lst = LMap.to_kv_list m in - let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in - let new_pp ppf (_k, v) = fprintf ppf "%a" value v in + 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 @@ -105,6 +104,8 @@ let constant ppf : constant' -> unit = function | C_SET_FOLD -> fprintf ppf "SET_FOLD" | C_SET_MEM -> fprintf ppf "SET_MEM" (* List *) + | C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY" + | C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL" | C_LIST_ITER -> fprintf ppf "LIST_ITER" | C_LIST_MAP -> fprintf ppf "LIST_MAP" | C_LIST_FOLD -> fprintf ppf "LIST_FOLD" @@ -154,43 +155,50 @@ let constant ppf : constant' -> unit = function let literal ppf (l : literal) = match l with - | Literal_unit -> - fprintf ppf "unit" - | Literal_void -> - fprintf ppf "void" - | Literal_bool b -> - fprintf ppf "%b" b - | Literal_int n -> - fprintf ppf "%d" n - | Literal_nat n -> - fprintf ppf "+%d" n - | Literal_timestamp n -> - fprintf ppf "+%d" n - | Literal_mutez n -> - fprintf ppf "%dmutez" n - | Literal_string s -> - fprintf ppf "%S" s - | Literal_bytes b -> - fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b) - | Literal_address s -> - fprintf ppf "@%S" s - | Literal_operation _ -> - fprintf ppf "Operation(...bytes)" - | Literal_key s -> - fprintf ppf "key %s" s - | Literal_key_hash s -> - fprintf ppf "key_hash %s" s - | Literal_signature s -> - fprintf ppf "Signature %s" s - | Literal_chain_id s -> - fprintf ppf "Chain_id %s" s + | Literal_unit -> fprintf ppf "unit" + | Literal_void -> fprintf ppf "void" + | Literal_bool b -> fprintf ppf "%b" b + | Literal_int n -> fprintf ppf "%d" n + | Literal_nat n -> fprintf ppf "+%d" n + | Literal_timestamp n -> fprintf ppf "+%d" n + | Literal_mutez n -> fprintf ppf "%dmutez" n + | Literal_string s -> fprintf ppf "%S" s + | Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b) + | Literal_address s -> fprintf ppf "@%S" s + | Literal_operation _ -> fprintf ppf "Operation(...bytes)" + | Literal_key s -> fprintf ppf "key %s" s + | Literal_key_hash s -> fprintf ppf "key_hash %s" s + | Literal_signature s -> fprintf ppf "Signature %s" s + | Literal_chain_id s -> fprintf ppf "Chain_id %s" s + +let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t + +and type_constant ppf (tc : type_constant) : unit = +let s = + match tc with + | TC_unit -> "unit" + | TC_string -> "string" + | TC_bytes -> "bytes" + | TC_nat -> "nat" + | TC_int -> "int" + | TC_mutez -> "mutez" + | TC_bool -> "bool" + | TC_operation -> "operation" + | TC_address -> "address" + | TC_key -> "key" + | TC_key_hash -> "key_hash" + | TC_signature -> "signature" + | TC_timestamp -> "timestamp" + | TC_chain_id -> "chain_id" + | TC_void -> "void" +in +fprintf ppf "%s" s + module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct module Agt=Ast_generic_type(PARAMETER) open Agt open Format - let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t - let rec type_expression' : (formatter -> type_expression -> unit) -> formatter @@ -198,58 +206,16 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct -> unit = fun f ppf te -> match te.type_content with - | T_sum m -> - fprintf ppf "sum[%a]" (cmap_sep_d f) m - | T_record m -> - fprintf ppf "%a" (tuple_or_record_sep_type f) m - | T_arrow a -> - fprintf ppf "%a -> %a" f a.type1 f a.type2 - | T_variable tv -> - type_variable ppf tv - | T_constant tc -> - type_constant ppf tc - | T_operator to_ -> - type_operator f ppf to_ + | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator f ppf to_ and type_expression ppf (te : type_expression) : unit = type_expression' type_expression ppf te - and type_constant ppf (tc : type_constant) : unit = - let s = - match tc with - | TC_unit -> - "unit" - | TC_string -> - "string" - | TC_bytes -> - "bytes" - | TC_nat -> - "nat" - | TC_int -> - "int" - | TC_mutez -> - "mutez" - | TC_bool -> - "bool" - | TC_operation -> - "operation" - | TC_address -> - "address" - | TC_key -> - "key" - | TC_key_hash -> - "key_hash" - | TC_signature -> - "signature" - | TC_timestamp -> - "timestamp" - | TC_chain_id -> - "chain_id" - | TC_void -> - "void" - in - fprintf ppf "%s" s - and type_operator : (formatter -> type_expression -> unit) -> formatter @@ -263,6 +229,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_set te -> Format.asprintf "set(%a)" f te | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_map_or_big_map (k, v) -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in diff --git a/src/stages/common/helpers.ml b/src/stages/common/helpers.ml index 5dba263b8..91cd0eae1 100644 --- a/src/stages/common/helpers.ml +++ b/src/stages/common/helpers.ml @@ -46,3 +46,23 @@ let get_pair m = match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with | Some e1, Some e2 -> ok (e1,e2) | _ -> simple_fail "not a pair" + +let tuple_of_record (m: _ LMap.t) = + let aux i = + let label = Label (string_of_int i) in + let opt = LMap.find_opt (label) m in + Option.bind (fun opt -> Some ((label,opt),i+1)) opt + in + Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux + +let list_of_record_or_tuple (m: _ LMap.t) = + if (is_tuple_lmap m) then + List.map snd @@ tuple_of_record m + else + List.rev @@ LMap.to_list m + +let kv_list_of_record_or_tuple (m: _ LMap.t) = + if (is_tuple_lmap m) then + tuple_of_record m + else + List.rev @@ LMap.to_kv_list m diff --git a/src/stages/common/helpers.mli b/src/stages/common/helpers.mli index d5e388e36..1292bb807 100644 --- a/src/stages/common/helpers.mli +++ b/src/stages/common/helpers.mli @@ -1,3 +1,5 @@ +open Types + val bind_lmap : ('a * 'b list, 'c) result Types.label_map -> ('a Types.label_map * 'b list, 'c) result @@ -19,6 +21,9 @@ val is_tuple_lmap : 'a Types.label_map -> bool val get_pair : 'a Types.label_map -> (('a * 'a) * 'b list, unit -> Trace.error) result +val tuple_of_record : 'a LMap.t -> (label * 'a) list +val list_of_record_or_tuple : 'a LMap.t -> 'a list +val kv_list_of_record_or_tuple : 'a LMap.t -> (label * 'a) list diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 20964d3b6..8e3411527 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -53,6 +53,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_set of type_expression | TC_map of type_expression * type_expression | TC_big_map of type_expression * type_expression + | TC_map_or_big_map of type_expression * type_expression | TC_arrow of type_expression * type_expression @@ -66,6 +67,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_set x -> TC_set (f x) | TC_map (x , y) -> TC_map (f x , f y) | TC_big_map (x , y)-> TC_big_map (f x , f y) + | TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y) | TC_arrow (x, y) -> TC_arrow (f x, f y) let bind_map_type_operator f = function @@ -75,6 +77,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_set x -> let%bind x = f x in ok @@ TC_set x | TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y) | TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y) + | TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y) | TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y) let type_operator_name = function @@ -84,6 +87,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_set _ -> "TC_set" | TC_map _ -> "TC_map" | TC_big_map _ -> "TC_big_map" + | TC_map_or_big_map _ -> "TC_map_or_big_map" | TC_arrow _ -> "TC_arrow" let type_expression'_of_string = function @@ -122,6 +126,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_set x -> "TC_set" , [x] | TC_map (x , y) -> "TC_map" , [x ; y] | TC_big_map (x , y) -> "TC_big_map" , [x ; y] + | TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] | TC_arrow (x , y) -> "TC_arrow" , [x ; y] let string_of_type_constant = function @@ -247,6 +252,8 @@ and constant' = | C_SET_FOLD | C_SET_MEM (* List *) + | C_LIST_EMPTY + | C_LIST_LITERAL | C_LIST_ITER | C_LIST_MAP | C_LIST_FOLD diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 4b60cf454..6b950eccd 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -136,7 +136,7 @@ module Substitution = struct and s_matching_expr : T.matching_expr w = fun ~substs _ -> let _TODO = substs in failwith "TODO: subst: unimplemented case s_matching" - and s_accessor : T.accessor w = fun ~substs _ -> + and s_accessor : T.record_accessor w = fun ~substs _ -> let _TODO = substs in failwith "TODO: subst: unimplemented case s_access_path" @@ -182,38 +182,14 @@ module Substitution = struct * let val_ = s_expression ~v ~expr val_ in * ok @@ (key , val_)) aemap in * ok @@ T.E_record aemap *) - | T.E_record_accessor {expr=e;label} -> - let%bind expr = s_expression ~substs e in - let%bind label = s_label ~substs label in - ok @@ T.E_record_accessor {expr;label} + | T.E_record_accessor {record=e;path} -> + let%bind record = s_expression ~substs e in + let%bind path = s_label ~substs path in + ok @@ T.E_record_accessor {record;path} | T.E_record_update {record;path;update}-> let%bind record = s_expression ~substs record in let%bind update = s_expression ~substs update in ok @@ T.E_record_update {record;path;update} - | T.E_map val_val_list -> - let%bind val_val_list = bind_map_list (fun (val1 , val2) -> - let%bind val1 = s_expression ~substs val1 in - let%bind val2 = s_expression ~substs val2 in - ok @@ (val1 , val2) - ) val_val_list in - ok @@ T.E_map val_val_list - | T.E_big_map val_val_list -> - let%bind val_val_list = bind_map_list (fun (val1 , val2) -> - let%bind val1 = s_expression ~substs val1 in - let%bind val2 = s_expression ~substs val2 in - ok @@ (val1 , val2) - ) val_val_list in - ok @@ T.E_big_map val_val_list - | T.E_list vals -> - let%bind vals = bind_map_list (s_expression ~substs) vals in - ok @@ T.E_list vals - | T.E_set vals -> - let%bind vals = bind_map_list (s_expression ~substs) vals in - ok @@ T.E_set vals - | T.E_look_up (val1, val2) -> - let%bind val1 = s_expression ~substs val1 in - let%bind val2 = s_expression ~substs val2 in - ok @@ T.E_look_up (val1 , val2) | T.E_matching {matchee;cases} -> let%bind matchee = s_expression ~substs matchee in let%bind cases = s_matching_expr ~substs cases in diff --git a/src/test/contracts/loop.ligo b/src/test/contracts/loop.ligo index 7866a5cdb..03c1671ba 100644 --- a/src/test/contracts/loop.ligo +++ b/src/test/contracts/loop.ligo @@ -54,9 +54,9 @@ function for_collection_if_and_local_var (var nee : unit) : int is block { var acc : int := 0; const theone : int = 1; + const thetwo : int = 2; var myset : set (int) := set [1; 2; 3]; for x in set myset block { - const thetwo : int = 2; if x = theone then acc := acc + x else if x = thetwo then acc := acc + thetwo else acc := acc + 10 diff --git a/src/test/contracts/tuple.ligo b/src/test/contracts/tuple.ligo index afe953345..963d1aa51 100644 --- a/src/test/contracts/tuple.ligo +++ b/src/test/contracts/tuple.ligo @@ -13,6 +13,11 @@ const fb : foobar = (0,0) function projection (const tpl : foobar) : int is tpl.0 + tpl.1 -type big_tuple is int * int * int * int * int +type big_tuple is int * int * int * int * int * int * int * int * int * int * int * int -const br : big_tuple = (23, 23, 23, 23, 23) +const br : big_tuple = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11) + +function update (const tpl : big_tuple) : big_tuple is + block { + tpl.11 := 2048 + } with tpl diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 4006d6b79..c1929f55b 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -876,9 +876,14 @@ let tuple () : unit result = expect_eq_n program "modify_abc" make_input make_expected in let%bind () = - let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in + let expected = ez [0 ; 1 ; 2 ; 3 ; 4; 5; 6; 7; 8; 9; 10; 11] in expect_eq_evaluate program "br" expected in + let%bind () = + let make_input = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; n] in + let make_expected = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; 2048] in + expect_eq_n program "update" make_input make_expected + in ok () let tuple_mligo () : unit result = diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index 8b2b8972b..24912c289 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -33,7 +33,7 @@ let empty_message = e_lambda (Var.of_name "arguments") empty_op_list let empty_message2 = e_lambda (Var.of_name "arguments") (Some t_bytes) (Some (t_list t_operation)) - ( e_let_in ((Var.of_name "foo"),Some t_unit) false false (e_unit ()) empty_op_list) + ( e_let_in ((Var.of_name "foo"),Some t_unit) false (e_unit ()) empty_op_list) let send_param msg = e_constructor "Send" msg let withdraw_param = e_constructor "Withdraw" empty_message