From 84d8da97ec5c286208cc3469f3312846fe425fb2 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 25 Mar 2020 14:47:41 -0500 Subject: [PATCH 1/3] Delete flaky webide test (for now) --- tools/webide/packages/e2e/test/deploy.spec.js | 38 ------------------- 1 file changed, 38 deletions(-) delete mode 100644 tools/webide/packages/e2e/test/deploy.spec.js diff --git a/tools/webide/packages/e2e/test/deploy.spec.js b/tools/webide/packages/e2e/test/deploy.spec.js deleted file mode 100644 index 958774cae..000000000 --- a/tools/webide/packages/e2e/test/deploy.spec.js +++ /dev/null @@ -1,38 +0,0 @@ -const commonUtils = require('./common-utils'); - -const API_HOST = commonUtils.API_HOST; - -const runCommandAndGetOutputFor = commonUtils.runCommandAndGetOutputFor; -const clearText = commonUtils.clearText; - -const COMMAND = 'deploy'; -const COMMAND_ENDPOINT = 'deploy'; - -async function deploy() { - return await runCommandAndGetOutputFor(COMMAND, COMMAND_ENDPOINT); -} - -describe('Deploy contract', () => { - beforeAll(() => jest.setTimeout(60000)); - - beforeEach(async () => await page.goto(API_HOST)); - - it('should deploy', async done => { - expect(await deploy()).toContain('The contract was successfully deployed to the carthage test network.'); - - done(); - }); - - it('should fail to deploy contract with invalid storage', async done => { - await page.click('#command-select'); - await page.click(`#deploy`); - - await page.click(`#storage`); - await clearText(page.keyboard); - await page.keyboard.type('asdf'); - - expect(await deploy()).toContain('Error: '); - - done(); - }); -}); From 57fc351907cf909524fa40cf9560e8479b370724 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 1 Apr 2020 14:22:05 -0500 Subject: [PATCH 2/3] Remove dexter.ligo --- dexter.ligo | 585 ---------------------------------------------------- 1 file changed, 585 deletions(-) delete mode 100644 dexter.ligo diff --git a/dexter.ligo b/dexter.ligo deleted file mode 100644 index 0af2bb11d..000000000 --- a/dexter.ligo +++ /dev/null @@ -1,585 +0,0 @@ -// 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); From 6fed8998bb49a839ac3e1bc563fed1cc545344b3 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Mon, 23 Mar 2020 15:14:55 -0500 Subject: [PATCH 3/3] Somewhat better PP for ast_core and mini_c --- src/bin/expect_tests/contract_tests.ml | 8 +- src/bin/expect_tests/typer_error_tests.ml | 4 +- .../11-self_mini_c/michelson_restrictions.ml | 6 +- src/passes/11-self_mini_c/subst.ml | 62 +++++++-------- src/stages/3-ast_core/PP.ml | 38 +++++----- src/stages/5-mini_c/PP.ml | 76 ++++++++++--------- src/stages/common/PP.ml | 18 ++--- 7 files changed, 109 insertions(+), 103 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 3419ad93b..5cff60cca 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -26,7 +26,7 @@ let%expect_test _ = run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; [%expect {| - ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]"} + ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]"} If you're not sure how to fix this error, you can @@ -39,7 +39,7 @@ let%expect_test _ = run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; [%expect {| - ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]"} + ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]"} If you're not sure how to fix this error, you can @@ -1117,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#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"} +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\n let rhs#702 = #P in\n let p = rhs#702.0 in\n let s = rhs#702.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"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 @@ -1130,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#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"} +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\n let rhs#705 = #P in\n let p = rhs#705.0 in\n let s = rhs#705.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 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 diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index facf1e75c..a52cd6e68 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -158,7 +158,9 @@ let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ; [%expect {| - ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , owner -> address , profile -> bytes] + ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , + owner -> address , + profile -> bytes] If you're not sure how to fix this error, you can do one of the following: diff --git a/src/passes/11-self_mini_c/michelson_restrictions.ml b/src/passes/11-self_mini_c/michelson_restrictions.ml index 80fe2cf73..88bab055f 100644 --- a/src/passes/11-self_mini_c/michelson_restrictions.ml +++ b/src/passes/11-self_mini_c/michelson_restrictions.ml @@ -5,9 +5,9 @@ module Errors = struct let bad_self_address cst () = let title = thunk @@ - Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in + Format.asprintf "Wrong %a location" Stage_common.PP.constant cst in let message = thunk @@ - Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in + Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in error title message () end @@ -19,7 +19,7 @@ let self_in_lambdas : expression -> expression result = | E_closure {binder=_ ; body} -> let%bind _self_in_lambdas = Helpers.map_expression (fun e -> match e.content with - | E_constant {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c) + | E_constant {cons_name=C_SELF_ADDRESS; _} -> fail (bad_self_address C_SELF_ADDRESS) | _ -> ok e) body in ok e diff --git a/src/passes/11-self_mini_c/subst.ml b/src/passes/11-self_mini_c/subst.ml index 1637a7bbe..def581f96 100644 --- a/src/passes/11-self_mini_c/subst.ml +++ b/src/passes/11-self_mini_c/subst.ml @@ -225,7 +225,7 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x))[x := L(unit)] = + (x)[x := L(unit)] = L(unit) |}] ; (* other var *) @@ -235,8 +235,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(y))[x := L(unit)] = - V(y) + (y)[x := L(unit)] = + y |}] ; (* closure shadowed *) @@ -246,8 +246,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (C(fun x -> (V(x))))[x := L(unit)] = - C(fun x -> (V(x))) + (fun x -> (x))[x := L(unit)] = + fun x -> (x) |}] ; (* closure not shadowed *) @@ -257,8 +257,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (C(fun y -> (V(x))))[x := L(unit)] = - C(fun y -> (L(unit))) + (fun y -> (x))[x := L(unit)] = + fun y -> (L(unit)) |}] ; (* closure capture-avoidance *) @@ -268,8 +268,8 @@ let%expect_test _ = ~x:x ~expr:(wrap (E_variable y)) ; [%expect{| - (C(fun y -> ((V(x))@(V(y)))))[x := V(y)] = - C(fun y#1 -> ((V(y))@(V(y#1)))) + (fun y -> ((x)@(y)))[x := y] = + fun y#1 -> ((y)@(y#1)) |}] ; (* let-in shadowed (not in rhs) *) @@ -279,8 +279,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (let x = V(x) in ( V(x) ))[x := L(unit)] = - let x = L(unit) in ( V(x) ) + (let x = x in x)[x := L(unit)] = + let x = L(unit) in x |}] ; (* let-in not shadowed *) @@ -290,8 +290,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (let y = V(x) in ( V(x) ))[x := L(unit)] = - let y = L(unit) in ( L(unit) ) + (let y = x in x)[x := L(unit)] = + let y = L(unit) in L(unit) |}] ; (* let-in capture avoidance *) @@ -302,8 +302,8 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (let y = V(x) in ( (V(x))@(V(y)) ))[x := V(y)] = - let y#1 = V(y) in ( (V(y))@(V(y#1)) ) + (let y = x in (x)@(y))[x := y] = + let y#1 = y in (y)@(y#1) |}] ; (* iter shadowed *) @@ -313,8 +313,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (for_ITER x of V(x) do ( V(x) ))[x := L(unit)] = - for_ITER x of L(unit) do ( V(x) ) + (for_ITER x of x do ( x ))[x := L(unit)] = + for_ITER x of L(unit) do ( x ) |}] ; (* iter not shadowed *) @@ -324,7 +324,7 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (for_ITER y of V(x) do ( V(x) ))[x := L(unit)] = + (for_ITER y of x do ( x ))[x := L(unit)] = for_ITER y of L(unit) do ( L(unit) ) |}] ; @@ -335,8 +335,8 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (for_ITER y of (V(x))@(V(y)) do ( (V(x))@(V(y)) ))[x := V(y)] = - for_ITER y#1 of (V(y))@(V(y)) do ( (V(y))@(V(y#1)) ) + (for_ITER y of (x)@(y) do ( (x)@(y) ))[x := y] = + for_ITER y#1 of (y)@(y) do ( (y)@(y#1) ) |}] ; (* if_cons shadowed 1 *) @@ -349,8 +349,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x) ?? V(x) : (x :: y) -> V(x))[x := L(unit)] = - L(unit) ?? L(unit) : (x :: y) -> V(x) + (x ?? x : (x :: y) -> x)[x := L(unit)] = + L(unit) ?? L(unit) : (x :: y) -> x |}] ; (* if_cons shadowed 2 *) @@ -363,8 +363,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x) ?? V(x) : (y :: x) -> V(x))[x := L(unit)] = - L(unit) ?? L(unit) : (y :: x) -> V(x) + (x ?? x : (y :: x) -> x)[x := L(unit)] = + L(unit) ?? L(unit) : (y :: x) -> x |}] ; (* if_cons not shadowed *) @@ -377,7 +377,7 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x) ?? V(x) : (y :: z) -> V(x))[x := L(unit)] = + (x ?? x : (y :: z) -> x)[x := L(unit)] = L(unit) ?? L(unit) : (y :: z) -> L(unit) |}] ; @@ -391,8 +391,8 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(y)] = - V(y) ?? V(y) : (y#1 :: z) -> (V(y))@((V(y#1))@(V(z))) + (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := y] = + y ?? y : (y#1 :: z) -> (y)@((y#1)@(z)) |}] ; (* if_cons capture avoidance 2 *) @@ -405,8 +405,8 @@ let%expect_test _ = ~x:x ~expr:(var z) ; [%expect{| - (V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(z)] = - V(z) ?? V(z) : (y :: z#1) -> (V(z))@((V(y))@(V(z#1))) + (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := z] = + z ?? z : (y :: z#1) -> (z)@((y)@(z#1)) |}] ; (* old bug *) @@ -417,6 +417,6 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (C(fun y -> (C(fun y#1 -> ((V(x))@((V(y))@(V(y#1))))))))[x := V(y)] = - C(fun y#2 -> (C(fun y#1 -> ((V(y))@((V(y#2))@(V(y#1))))))) + (fun y -> (fun y#1 -> ((x)@((y)@(y#1)))))[x := y] = + fun y#2 -> (fun y#1 -> ((y)@((y#2)@(y#1)))) |}] ; diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index 2909d4dc8..ac760dbba 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -19,20 +19,20 @@ and expression_content ppf (ec : expression_content) = | E_variable n -> fprintf ppf "%a" expression_variable n | E_application {lamb;args} -> - fprintf ppf "(%a)@(%a)" expression lamb expression args + fprintf ppf "@[(%a)@@(%a)@]" expression lamb expression args | E_constructor c -> - fprintf ppf "%a(%a)" constructor c.constructor expression c.element + fprintf ppf "@[%a(%a)@]" constructor c.constructor expression c.element | E_constant c -> - fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) + fprintf ppf "@[%a@[(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.record label ra.path + 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@;<1 2>with@;<1 2>{ %a = %a } }@]" expression record label path expression update | E_lambda {binder; input_type; output_type; result} -> - fprintf ppf "lambda (%a:%a) : %a return %a" + fprintf ppf "@[lambda (%a:%a) : %a@ return@ %a@]" expression_variable binder (PP_helpers.option type_expression) input_type @@ -44,10 +44,10 @@ and expression_content ppf (ec : expression_content) = type_expression fun_type expression_content (E_lambda lambda) | E_matching {matchee; cases; _} -> - fprintf ppf "match %a with %a" expression matchee (matching expression) + 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 + fprintf ppf "@[let %a =@;<1 2>%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 @@ -61,27 +61,27 @@ and option_type_name ppf fprintf ppf "%a : %a" expression_variable n type_expression ty and assoc_expression ppf : expr * expr -> unit = - fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b + fun (a, b) -> fprintf ppf "@[<2>%a ->@;<1 2>%a@]" expression a expression b and single_record_patch ppf ((p, expr) : label * expr) = fprintf ppf "%a <- %a" label p expression expr and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = fun f ppf ((c,n),a) -> - fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a + fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = fun f ppf m -> match m with | Match_tuple ((lst, b), _) -> - fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b + fprintf ppf "@[| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b | Match_variant (lst, _) -> - fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst + fprintf ppf "@[%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst | Match_bool {match_true ; match_false} -> - fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false + fprintf ppf "@[| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]" f match_true f match_false | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> - fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons + fprintf ppf "@[| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%a@]" f match_nil expression_variable hd expression_variable tl f match_cons | Match_option {match_none ; match_some = (some, match_some, _)} -> - fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some + fprintf ppf "@[| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]" f match_none expression_variable some f match_some (* Shows the type expected for the matched value *) and matching_type ppf m = match m with @@ -101,22 +101,22 @@ and matching_variant_case_type ppf ((c,n),_a) = and option_mut ppf mut = if mut then - fprintf ppf "[@mut]" + fprintf ppf "[@@mut]" else fprintf ppf "" and option_inline ppf inline = if inline then - fprintf ppf "[@inline]" + fprintf ppf "[@@inline]" else fprintf ppf "" let declaration ppf (d : declaration) = match d with | Declaration_type (type_name, te) -> - fprintf ppf "type %a = %a" type_variable type_name type_expression te + fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te | Declaration_constant (name, ty_opt, i, expr) -> - fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression + fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression expr option_inline i diff --git a/src/stages/5-mini_c/PP.ml b/src/stages/5-mini_c/PP.ml index 808b65873..908a30e22 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -3,23 +3,21 @@ open Simple_utils.PP_helpers open Types open Format -let list_sep_d x = list_sep x (const " , ") - -let space_sep ppf () = fprintf ppf " " +let list_sep_d x = list_sep x (tag " ,@ ") let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R" let rec type_variable ppf : type_value -> _ = function - | T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b - | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b + | T_or(a, b) -> fprintf ppf "@[(%a) |@ (%a)@]" annotated a annotated b + | T_pair(a, b) -> fprintf ppf "@[(%a) &@ (%a)@]" annotated a annotated b | T_base b -> type_constant ppf b - | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b - | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v - | T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v - | T_list(t) -> fprintf ppf "list(%a)" type_variable t - | T_set(t) -> fprintf ppf "set(%a)" type_variable t - | T_option(o) -> fprintf ppf "option(%a)" type_variable o - | T_contract(t) -> fprintf ppf "contract(%a)" type_variable t + | T_function(a, b) -> fprintf ppf "@[(%a) ->@ (%a)@]" type_variable a type_variable b + | T_map(k, v) -> fprintf ppf "@[<4>map(%a -> %a)@]" type_variable k type_variable v + | T_big_map(k, v) -> fprintf ppf "@[<9>big_map(%a -> %a)@]" type_variable k type_variable v + | T_list(t) -> fprintf ppf "@[<5>list(%a)@]" type_variable t + | T_set(t) -> fprintf ppf "@[<4>set(%a)@]" type_variable t + | T_option(o) -> fprintf ppf "@[<7>option(%a)@]" type_variable o + | T_contract(t) -> fprintf ppf "@[<9>contract(%a)@]" type_variable t and annotated ppf : type_value annotated -> _ = function | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann @@ -80,30 +78,38 @@ and expression ppf (e:expression) = and expression' ppf (e:expression') = match e with | E_skip -> fprintf ppf "skip" - | E_closure x -> fprintf ppf "C(%a)" function_ x - | E_variable v -> fprintf ppf "V(%a)" Var.pp v - | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b + | E_closure x -> function_ ppf x + | E_variable v -> fprintf ppf "%a" Var.pp v + | E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b - | 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_constant c -> fprintf ppf "@[%a@[(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments + | E_literal v -> fprintf ppf "@[L(%a)@]" value v | 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 - | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Var.pp hd_name Var.pp tl_name expression cons + | E_if_bool (c, a, b) -> + fprintf ppf + "@[match %a with@ @[| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]@]" + expression c expression a expression b + | E_if_none (c, n, ((name, _) , s)) -> + fprintf ppf + "@[match %a with@ @[| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]" + expression c expression n Var.pp name expression s + | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]" expression c expression n Var.pp hd_name Var.pp tl_name expression cons | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> - fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Var.pp name_l expression l Var.pp name_r expression r - | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b + fprintf ppf + "@[match %a with@ @[| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]" + expression c Var.pp name_l expression l Var.pp name_r expression r + | E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b | E_let_in ((name , _) , inline, expr , body) -> - fprintf ppf "let %a = %a%a in ( %a )" Var.pp name expression expr option_inline inline expression body + fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name expression expr option_inline inline expression body | E_iterator (b , ((name , _) , body) , expr) -> - fprintf ppf "for_%a %a of %a do ( %a )" constant b Var.pp name expression expr expression body + fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name expression expr expression body | E_fold (((name , _) , body) , collection , initial) -> - fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body + fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name expression body | E_record_update (r, path,update) -> - fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update + fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update | E_while (e , b) -> - fprintf ppf "while %a do %a" expression e expression b + fprintf ppf "@[while %a do %a@]" expression e expression b and expression_with_type : _ -> expression -> _ = fun ppf e -> fprintf ppf "%a : %a" @@ -111,24 +117,22 @@ and expression_with_type : _ -> expression -> _ = fun ppf e -> type_variable e.type_value and function_ ppf ({binder ; body}:anon_function) = - fprintf ppf "fun %a -> (%a)" + fprintf ppf "@[fun %a ->@ (%a)@]" Var.pp binder expression body -and assignment ppf ((n, i, e):assignment) = fprintf ppf "%a = %a%a;" Var.pp n expression e option_inline i - and option_inline ppf inline = if inline then - fprintf ppf "[@inline]" + fprintf ppf "[@@inline]" else fprintf ppf "" -and declaration ppf ((n,i, e):assignment) = fprintf ppf "let %a = %a%a;" Var.pp n expression e option_inline i +and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n expression e option_inline i -and tl_statement ppf (ass, _) = assignment ppf ass +and tl_statement ppf (ass, _) = declaration ppf ass and program ppf (p:program) = - fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p + fprintf ppf "@[%a@]" (pp_print_list ~pp_sep:(tag "@ ") tl_statement) p and constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" @@ -254,9 +258,9 @@ let%expect_test _ = let wrap e = { content = e ; type_value = dummy_type } in pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ; [%expect{| - C(fun y -> (V(y))) + fun y -> (y) |}] ; pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ; [%expect{| - C(fun z -> (V(z))) + fun z -> (z) |}] diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 832609b47..5204c93f0 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -11,13 +11,13 @@ let label ppf (l:label) : unit = let cmap_sep value sep ppf m = let lst = CMap.to_kv_list m in let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in - let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in + let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" constructor k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let record_sep value sep ppf (m : 'a label_map) = let lst = LMap.to_kv_list m in let lst = List.sort_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 + 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 = @@ -30,14 +30,14 @@ let tuple_sep value sep ppf m = 0..(cardinal-1) as tuples *) let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m = if Helpers.is_tuple_lmap m then - fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m + fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m else - fprintf ppf format_record (record_sep value (const sep_record)) m + fprintf ppf format_record (record_sep value (tag sep_record)) m -let list_sep_d x = list_sep x (const " , ") -let cmap_sep_d x = cmap_sep x (const " , ") -let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , " -let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * " +let list_sep_d x = list_sep x (tag " ,@ ") +let cmap_sep_d x = cmap_sep x (tag " ,@ ") +let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " +let tuple_or_record_sep_type value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " let constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" @@ -206,7 +206,7 @@ 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_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