diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f6e6b62ed..0fb22a317 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -12,32 +12,8 @@ stages: stage: build_and_deploy_website image: node:8 before_script: - - cd gitlab-pages/website - - npm install - script: - - npm run version next - - npm run build - after_script: - - cp -r gitlab-pages/website/build/ligo public - artifacts: - paths: - - public - -.docker: &docker - image: docker:1.11 - services: - - docker:dind - -.docker_build: &docker_build - script: - - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . - -.before_script: &before_script - before_script: - # Install dependencies - # rsync is needed by opam to sync a package installed from a local directory with the copy in ~/.opam - - apt-get update -qq - - apt-get -y -qq install rsync libhidapi-dev libcap-dev libev-dev bubblewrap + - scripts/install_native_dependencies.sh + # TODO: these things are moved to scripts in other branches. - wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux - cp opam-2.0.1-x86_64-linux /usr/local/bin/opam - chmod +x /usr/local/bin/opam @@ -57,12 +33,69 @@ stages: - printf '' | ocaml - opam switch + # install deps for internal documentation + - opam install -y odoc + - vendors/opam-repository-tools/rewrite-local-opam-repository.sh + - opam repository add localrepo "file://$PWD/vendors/ligo-opam-repository-local-generated/" + - opam install -y --build-test --deps-only ./src/ + - dune build -p ligo + # TODO: also try instead from time to time: + #- (cd ./src/; dune build -p ligo) + + # build with odoc + - dune build @doc + + # npm + - cd gitlab-pages/website + - npm install + script: + - npm run version next + - npm run build + # move internal odoc documentation to the website folder + - mkdir -p build/ligo/ + - mv ../../_build/default/_doc/_html/ build/ligo/odoc + - pwd # for debug + - ls build/ligo/ # for debug + after_script: + - cp -r gitlab-pages/website/build/ligo public + artifacts: + paths: + - public + +.docker: &docker + image: docker:1.11 + services: + - docker:dind + +.docker_build: &docker_build + script: + - docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile . + +.before_script: &before_script + before_script: + # Install dependencies + # rsync is needed by opam to sync a package installed from a local directory with the copy in ~/.opam + - apt-get update -qq + - scripts/install_native_dependencies.sh + - scripts/install_opam.sh + - export PATH="/usr/local/bin${PATH:+:}${PATH:-}" + + # Initialise opam, create switch, load opam environment variables + - printf '' | opam init --bare + - printf '' | opam switch create ligo-switch ocaml-base-compiler.4.06.1 + - eval $(opam config env) + + # Show versions and current switch + - echo "$PATH" + - opam --version + - printf '' | ocaml + - opam switch + local-dune-job: <<: *before_script stage: test script: - - vendors/opam-repository-tools/rewrite-local-opam-repository.sh - - opam repository add localrepo "file://$PWD/vendors/ligo-opam-repository-local-generated/" + - scripts/setup_ligo_opam_repository.sh - opam install -y --build-test --deps-only ./src/ - dune build -p ligo # TODO: also try instead from time to time: @@ -126,4 +159,4 @@ pages: only: - master - dev - + - feature/website-fixes diff --git a/Makefile b/Makefile new file mode 100644 index 000000000..f70b9412a --- /dev/null +++ b/Makefile @@ -0,0 +1,3 @@ +build-deps: + scripts/install_native_dependencies.sh + scripts/install_opam.sh diff --git a/docker/Dockerfile b/docker/Dockerfile index 5cedfcd58..dbc051aee 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -16,12 +16,12 @@ ADD . /ligo # the upcoming scripts WORKDIR /ligo -# Setup a custom opam repository where ligo is published -RUN sh scripts/setup_ligo_opam_repository.sh - # Install required native dependencies RUN sh scripts/install_native_dependencies.sh +# Setup a custom opam repository where ligo is published +RUN sh scripts/setup_ligo_opam_repository.sh + RUN opam update # Install ligo diff --git a/gitlab-pages/docs/language-basics/cheat-sheet.md b/gitlab-pages/docs/language-basics/cheat-sheet.md index 1e0e7aaef..4d8510cfa 100644 --- a/gitlab-pages/docs/language-basics/cheat-sheet.md +++ b/gitlab-pages/docs/language-basics/cheat-sheet.md @@ -2,6 +2,8 @@ id: cheat-sheet title: Cheat Sheet --- +
+ @@ -29,9 +31,12 @@ title: Cheat Sheet |Assignment on an existing variable

*⚠️ This feature is not supported at the top-level scope, you can use it e.g. within functions. Works for Records and Maps as well.*| ```age := 18;```, ```p.age := 21``` | |Annotations| ```("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)```| |Variants|
type action is
| Increment of int
| Decrement of int
| -|Variant *(pattern)* matching|
const a: action = Increment(5);
case a of
| Increment n -> n + 1
| Decrement n -> n - 1
end
| +|Variant *(pattern)* matching|
const a: action = Increment(5);
case a of
| Increment(n) -> n + 1
| Decrement(n) -> n - 1
end
| |Records|
type person is record
  age: int ;
  name: string ;
end

const john : person = record
  age = 18;
  name = "John Doe";
end

const name: string = john.name;
| |Maps|
type prices is map(nat, tez);

const prices : prices = map
  10n -> 60mtz;
  50n -> 30mtz;
  100n -> 10mtz;
end

const price: option(tez) = prices[50n];
| +|Contracts & Accounts|
const destinationAddress : address = "tz1...";
const contract : contract(unit) = get_contract(destinationAddress);
| +|Transactions|
const payment : operation = transaction(unit, amount, receiver);
| + - \ No newline at end of file +
\ No newline at end of file diff --git a/gitlab-pages/docs/language-basics/entrypoints.md b/gitlab-pages/docs/language-basics/entrypoints.md index 3f17189b7..e666f8c10 100644 --- a/gitlab-pages/docs/language-basics/entrypoints.md +++ b/gitlab-pages/docs/language-basics/entrypoints.md @@ -37,8 +37,8 @@ type action is function main (const action: action ; const counter: int) : (list(operation) * int) is block {skip} with ((nil : list(operation)), case action of - | Increment number -> counter + number - | Decrement number -> counter - number + | Increment(number) -> counter + number + | Decrement(number) -> counter - number end) ``` diff --git a/gitlab-pages/docs/setup/installation.md b/gitlab-pages/docs/setup/installation.md index 2455d3bd7..66cef54bb 100644 --- a/gitlab-pages/docs/setup/installation.md +++ b/gitlab-pages/docs/setup/installation.md @@ -9,7 +9,7 @@ There are currently two ways to get started with Ligo, both of those will allow > 🐳 You can find instructions on how to install Docker [here](https://docs.docker.com/install/). -Easiest way to use LIGO is through the Docker image available at [Docker Hub](https://hub.docker.com/r/ligolang/ligo). Sources for the image can be found on [Gitlab](https://gitlab.com/ligolang/ligo/blob/master/docker/Dockerfile). +Easiest way to use LIGO is through the Docker image available at [Docker Hub](https://hub.docker.com/r/ligolang/ligo). Sources for the image can be found on [Gitlab](https://gitlab.com/ligolang/ligo/blob/dev/docker/Dockerfile). You can either run the docker image yourself, or you can setup a global ligo executable as shown below. ### Setting up a globally available `ligo` executable @@ -19,10 +19,13 @@ You can either run the docker image yourself, or you can setup a global ligo exe ```zsh # next (pre-release) curl https://gitlab.com/ligolang/ligo/raw/dev/scripts/installer.sh | bash -s "next" - +``` + **Verify your ligo installation by running:** ```zsh diff --git a/gitlab-pages/docs/tutorials/firsts-smart-contract.md b/gitlab-pages/docs/tutorials/firsts-smart-contract.md deleted file mode 100644 index b210a4d15..000000000 --- a/gitlab-pages/docs/tutorials/firsts-smart-contract.md +++ /dev/null @@ -1,6 +0,0 @@ ---- -id: first-smart-contract -title: My first LIGO smart contract ---- - -TODO \ No newline at end of file diff --git a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.ligo b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.ligo new file mode 100644 index 000000000..5623eaf3f --- /dev/null +++ b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.ligo @@ -0,0 +1,37 @@ +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +const ownerAddress: address = "tz1TGu6TN5GSez2ndXXeDX6LgUDvLzPLqgYV"; +const donationAddress: address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + begin + // Retrieve the taco_kind from the contract's storage + const taco_kind : taco_supply = get_force(taco_kind_index, taco_shop_storage); + + const current_purchase_price : tez = taco_kind.max_price / taco_kind.current_stock; + + if amount =/= current_purchase_price then + // we won't sell tacos if the amount isn't correct + fail("Sorry, the taco you're trying to purchase has a different price"); + else + // Decrease the stock by 1n, because we've just sold one + taco_kind.current_stock := abs(taco_kind.current_stock - 1n); + + // Update the storage with the refreshed taco_kind + taco_shop_storage[taco_kind_index] := taco_kind; + + const receiver: contract(unit) = get_contract(ownerAddress); + const donationReceiver: contract(unit) = get_contract(donationAddress); + + const donationAmount: tez = amount / 10n; + + const operations : list(operation) = list + transaction(unit, amount - donationAmount, receiver); + transaction(unit, donationAmount, donationReceiver); + end; + + end with (operations, taco_shop_storage) \ No newline at end of file diff --git a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md new file mode 100644 index 000000000..f22f59452 --- /dev/null +++ b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md @@ -0,0 +1,180 @@ +--- +id: tezos-taco-shop-payout +title: Paying out profits from the Taco Shop +--- + +In the [previous tutorial](tutorials/get-started/tezos-taco-shop-smart-contract.md) we've learned how to setup & interact with the LIGO CLI. Followed by implementation of a simple Taco Shop smart contract for our entepreneur Pedro. In this tutorial we'll make sure Pedro has access to tokens that people have spent at his shop when buying tacos. + + +
+ + +
+
Icons made by Smashicons from www.flaticon.com is licensed by CC 3.0 BY
+
+ + +## Analyzing the current contract + +### **`taco-shop.ligo`** +``` +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + begin + // Retrieve the taco_kind from the contract's storage + const taco_kind : taco_supply = get_force(taco_kind_index, taco_shop_storage); + + const current_purchase_price : tez = taco_kind.max_price / taco_kind.current_stock; + + if amount =/= current_purchase_price then + // we won't sell tacos if the amount isn't correct + fail("Sorry, the taco you're trying to purchase has a different price"); + else + // Decrease the stock by 1n, because we've just sold one + taco_kind.current_stock := abs(taco_kind.current_stock - 1n); + + // Update the storage with the refreshed taco_kind + taco_shop_storage[taco_kind_index] := taco_kind; + end with ((nil : list(operation)), taco_shop_storage) +``` + +### Purchase price formula +Pedro's Taco Shop contract currently enables customers to buy tacos, at a computed price based on a simple formula. + +``` +const current_purchase_price : tez = taco_kind.max_price / taco_kind.current_stock; +``` + +### Replacing *spendable* smart contracts +However, due to the [recent protocol upgrade](http://tezos.gitlab.io/mainnet/protocols/004_Pt24m4xi.html) of the Tezos mainnet, Pedro can't access the tokens stored in his Shop's contract directly. This was previously possible via `spendable` smart contracts, which are no longer available in the new protocol. We will have to implement a solution to access tokens from the contract programatically. + +--- + +## Designing a payout scheme + +Pedro is a standalone bussines owner, and in our case, he doesn't have to split profits / earnings of the taco shop with anyone. So for the sake of simplicity, we'll payout all the earned XTZ directly to Pedro right after a succesful taco purchase. + +This means that after all the *purchase conditions* of our contract are met - e.g. correct amount is sent to the contract - we'll not only decrease the supply of the individual purchased *taco kind*, but we'll also transfer this amount in a *subsequent transaction* to Pedro's personal address. + +## Forging a payout transaction + +### Defining the recipient +In order to send tokens, we will need a receiver address - which in our case will be Pedro's personal account. Additionally we'll wrap the given address as a *`contract(unit)`* - which represents either a contract with no parameters, or an implicit account. + +``` +const ownerAddress : address = "tz1TGu6TN5GSez2ndXXeDX6LgUDvLzPLqgYV"; +const receiver : contract(unit) = get_contract(ownerAddress); +``` + +> Would you like to learn more about addresses, contracts and operations in LIGO? Check out the [LIGO cheat sheet](language-basics/cheat-sheet.md) + +### Adding the transaction to the list of output operations +Now we can transfer the `amount` received by `buy_taco` to Pedro's `ownerAddress`. We will do so by forging a `transaction(unit, amount, receiver)` within a list of operations returned at the end of our contract. + + +``` +const payoutOperation : operation = transaction(unit, amount, receiver) ; +const operations : list(operation) = list + payoutOperation +end; +``` + +--- + +## Finalizing the contract + +### **`taco-shop.ligo`** +``` +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +const ownerAddress: address = "tz1TGu6TN5GSez2ndXXeDX6LgUDvLzPLqgYV"; + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + begin + // Retrieve the taco_kind from the contract's storage + const taco_kind : taco_supply = get_force(taco_kind_index, taco_shop_storage); + + const current_purchase_price : tez = taco_kind.max_price / taco_kind.current_stock; + + if amount =/= current_purchase_price then + // we won't sell tacos if the amount isn't correct + fail("Sorry, the taco you're trying to purchase has a different price"); + else + // Decrease the stock by 1n, because we've just sold one + taco_kind.current_stock := abs(taco_kind.current_stock - 1n); + + // Update the storage with the refreshed taco_kind + taco_shop_storage[taco_kind_index] := taco_kind; + + const receiver : contract(unit) = get_contract(ownerAddress); + const payoutOperation : operation = transaction(unit, amount, receiver); + const operations : list(operation) = list + payoutOperation + end; + + end with (operations, taco_shop_storage) +``` + + +### Dry-run the contract + +To confirm that our contract is valid, we can dry run it. As a result we see a *new operation* in the list of returned operations to be executed subsequently. + +``` +ligo dry-run taco-shop.ligo --syntax pascaligo --amount 1 buy_taco 1n "map + 1n -> record + current_stock = 50n; + max_price = 50000000mtz; + end; + 2n -> record + current_stock = 20n; + max_price = 75000000mtz; + end; +end" +``` + + +
+Operation(...bytes) included in the output +
+ +
+ +**Done! Our tokens are no longer locked in the contract, and instead they are sent to Pedro's personal account/wallet.** + +--- + +## 👼 Bonus: donating part of the profits + +Because Pedro is a member of the (STA) Specialty Taco Association, he has decided to donate **10%** of the earnings to the STA. We'll just add a `donationAddress` to the contract, and compute a 10% donation sum from each taco purchase. + +``` +const ownerAddress: address = "tz1TGu6TN5GSez2ndXXeDX6LgUDvLzPLqgYV"; +const donationAddress: address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; +``` + +``` +const receiver : contract(unit) = get_contract(ownerAddress); +const donationReceiver : contract(unit) = get_contract(donationAddress); + +const donationAmount: tez = amount / 10n; + +const operations : list(operation) = list + // Pedro will get 90% of the amount + transaction(unit, amount - donationAmount, receiver); + transaction(unit, donationAmount, donationReceiver); +end; +``` + +This will result into two operations being subsequently executed on the blockchain: +- Donation transfer (10%) +- Pedro's profits (90%) \ No newline at end of file diff --git a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.ligo b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.ligo new file mode 100644 index 000000000..b51460bde --- /dev/null +++ b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.ligo @@ -0,0 +1,23 @@ +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + begin + // Retrieve the taco_kind from the contract's storage + const taco_kind : taco_supply = get_force(taco_kind_index, taco_shop_storage); + + const current_purchase_price : tez = taco_kind.max_price / taco_kind.current_stock; + + if amount =/= current_purchase_price then + // we won't sell tacos if the amount isn't correct + fail("Sorry, the taco you're trying to purchase has a different price"); + else + // Decrease the stock by 1n, because we've just sold one + taco_kind.current_stock := abs(taco_kind.current_stock - 1n); + + // Update the storage with the refreshed taco_kind + taco_shop_storage[taco_kind_index] := taco_kind; + end with ((nil : list(operation)), taco_shop_storage) \ No newline at end of file diff --git a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md new file mode 100644 index 000000000..59970d4a8 --- /dev/null +++ b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md @@ -0,0 +1,335 @@ +--- +id: tezos-taco-shop-smart-contract +title: Taco shop smart-contract +--- + +
+ +Meet **Pedro**, our *artisan taco chef* who has decided to open a Taco shop on the Tezos blockchain, using a smart-contract. He sells two different kinds of tacos, the **el clásico** and the **especial del chef**. + +To help Pedro open his dream taco shop, we'll implement a smart-contract, that will manage supply, pricing & sales of his tacos to the consumers. + +
+ +
Made by Smashicons from www.flaticon.com is licensed by CC 3.0 BY
+
+ +--- + +## Pricing + +Pedro's tacos are a rare delicacy, so their **price goes up**, as the **stock for the day begins to deplete**. + +Each taco kind, has its own `max_price` that it sells for, and a finite supply for the current sales lifecycle. + +> For the sake of simplicity, we won't implement replenishing of the supply after it runs out. + +### Daily offer + +|**kind** |id |**available_stock**| **max_price**| +|---|---|---|---| +|el clásico | `1n` | `50n` | `50000000mtz` | +|especial del chef | `2n` | `20n` | `75000000mtz` | + +### Calculating the current purchase price + +Current purchase price is calculated with the following equation: + +``` +current_purchase_price = max_price / available_stock +``` + +#### El clásico +|**available_stock**|**max_price**|**current_purchase_price**| +|---|---|---| +| `50n` | `50000000mtz` | `1tz`| +| `20n` | `50000000mtz` | `2.5tz` | +| `5n` | `50000000mtz` | `10tz` | + +#### Especial del chef +|**available_stock**|**max_price**|**current_purchase_price**| +|---|---|---| +| `20n` | `75000000mtz` | `3.75tz` | +| `10n` | `75000000mtz` | `7.5tz`| +| `5n` | `75000000mtz` | `15tz` | + +--- + +## Installing LIGO + +In this tutorial, we'll use LIGO's dockerized version for the sake of simplicity. You can find the installation instructions [here](setup/installation.md#dockerized-installation-recommended). + + +
Installing the next version of LIGO's CLI
+ +## Implementing our first entry point + +> From now on we'll get a bit more technical. If you run into something we have not covered yet - please try checking out the [LIGO cheat sheet](language-basics/cheat-sheet.md) for some extra tips & tricks. + +To begin implementing our smart contract, we need an entry point. We'll call it `main` and it'll specify our contract's storage (`int`) and input parameter (`int`). Of course this is not the final storage/parameter of our contract, but it's something to get us started and test our LIGO installation as well. + +### `taco-shop.ligo` +```Pascal +function main (const parameter : int; const contractStorage : int) : (list(operation) * int) is + block {skip} with ((nil : list(operation)), contractStorage + parameter) +``` + +Let's break down the contract above to make sure we understand each bit of the LIGO syntax: + +- **`function main`** - definition of a function that serves as an entry point +- **`(const parameter : int; const contractStorage : int)`** - parameters passed to the function + - **`const parameter : int`** - parameter provided by a transaction that invokes our contract + - **`const contractStorage : int`** - definition of our storage (`int`) +- **`(list(operation) * int)`** - return type of our function, in our case a touple with a list of operations, and an int +- **`block {skip}`** - our function has no body, so we instruct LIGO to `skip` it +- **`with ((nil : list(operation)), contractStorage + parameter)`** - essentially a return statement + - **`(nil : list(operation))`** - a `nil` value annotated as a list of operations, because that's required by our return type specified above + - **`contractStorage + parameter`** - a new storage value for our contract, sum of previous storage and a transaction parameter +### Running LIGO for the first time + +To test that we've installed LIGO correctly, and that `taco-shop.ligo` is a valid contract, we'll dry-run it. + +> Dry-running is a simulated execution of the smart contract, based on a mock storage value and a parameter. + +Our contract has a storage of `int` and accepts a parameter that is also an `int`. + +The `dry-run` command requires a few parameters: +- **contract** *(file path)* +- **entrypoint** *(name of the entrypoint function in the contract)* +- **parameter** *(parameter to execute our contract with)* +- **storage** *(starting storage before our contract's code is executed)* + + +And outputs what's returned from our entrypoint - in our case a touple containing an empty list (of operations to apply) and the new storage value - which in our case is the sum of the previous storage and the parameter we've used. + +```zsh +# Contract: taco-shop.ligo +# Entry point: main +# Parameter: 4 +# Storage: 3 +ligo dry-run taco-shop.ligo --syntax pascaligo main 4 3 +# tuple[ list[] +# 7 +# ] +``` + + +
Simulating contract execution with the CLI
+ +
+ +*`3 + 4 = 7` yay! Our CLI & contract work as expected, we can move onto fulfilling Pedro's on-chain dream.* + +--- + +## Designing Taco shop's contract storage + +We know that Pedro's Taco Shop serves two kinds of tacos, so we'll need to manage stock individually, per kind. Let's define a type, that will keep the `stock` & `max_price` per kind - in a record with two fields. Additionally, we'll want to combine our `taco_supply` type into a map, consisting of the entire offer of Pedro's shop. + +**Taco shop's storage** +```Pascal +type taco_supply is record + current_stock : nat; + max_price : tez; +end + +type taco_shop_storage is map(nat, taco_supply); +``` + +Next step is to update the `main` entry point to include `taco_shop_storage` as its storage - while doing that let's set the `parameter` to `unit` as well to clear things up. + +**`taco-shop.ligo`** +```Pascal +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +function main (const parameter: unit ; const taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + block {skip} with ((nil : list(operation)), taco_shop_storage) +``` + +### Populating our storage in a dry-run + +When dry-running a contract, it's crucial to provide a correct initial storage value - in our case the storage is type-checked as `taco_shop_storage`. Reflecting [Pedro's daily offer](tutorials/get-started/tezos-taco-shop-smart-contract.md#daily-offer), our storage's value will be defined as following: + +**Storage value** +```zsh +map + 1n -> record + current_stock = 50n; + max_price = 50000000mtz; + end; + 2n -> record + current_stock = 20n; + max_price = 75000000mtz; + end; +end +``` + +> Storage value is a map, with two items in it, both items are records identified by natural numbers `1n` & `2n`. + +**Dry run command with a multi-line storage value** +```zsh +ligo dry-run taco-shop.ligo --syntax pascaligo main unit "map + 1n -> record + current_stock = 50n; + max_price = 50000000mtz; + end; + 2n -> record + current_stock = 20n; + max_price = 75000000mtz; + end; +end" +``` + + +
Dry-run with a complex storage value
+ +
+ +*If everything went as expected, the `dry-run` command will return an empty list of operations and the contract's current storage, which is the map of products we've defined based on the daily offer of Pedro's taco shop.* + +--- + +## Providing an entrypoint for buying tacos + +Now that we have our stock well defined in form of storage, we can move on to the actual sales. We'll replace the `main` entrypoint with `buy_taco`, that takes an `id` - effectively a key from our `taco_shop_storage` map. This will allow us to calculate pricing, and if the sale is successful - then we can reduce our stock - because we have sold a taco! + +### Selling the tacos for free + +Let's start by customizing our contract a bit, we will: + +- rename the entrypoint from `main` to `buy_taco` +- rename `parameter` to `taco_kind_index` +- change `taco_shop_storage` to a `var` instead of a `const`, because we'll want to modify it + +**`taco-shop.ligo`** +```Pascal +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + block { skip } with ((nil : list(operation)), taco_shop_storage) +``` + +#### Decreasing `current_stock` when a taco is sold + +In order to decrease the stock in our contract's storage for a specific taco kind, a few things needs to happen: + +- retrieve the `taco_kind` from our storage, based on the `taco_kind_index` provided +- subtract the `taco_kind.current_stock` by `1n` + - we can find the absolute (`nat`) value of the subtraction above by using `abs`, otherwise we'd be left with an `int` +- update the storage, and return it + +**`taco-shop.ligo`** + +```Pascal +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + begin + // Retrieve the taco_kind from the contract's storage + const taco_kind : taco_supply = get_force(taco_kind_index, taco_shop_storage); + // Decrease the stock by 1n, because we've just sold one + taco_kind.current_stock := abs(taco_kind.current_stock - 1n); + // Update the storage with the refreshed taco_kind + taco_shop_storage[taco_kind_index] := taco_kind; + end with ((nil : list(operation)), taco_shop_storage) +``` + + +
Stock decreases after selling a taco
+ +
+ +### Making sure we get paid for our tacos + +In order to make Pedro's taco shop profitable, he needs to stop giving away tacos for free. When a contract is invoked via a transaction, an amount of tezzies to be sent can be specified as well. This amount is accessible within LIGO as `amount`. + +To make sure we get paid, we will: + +- calculate a `current_purchase_price` based on the [equation specified earlier](tutorials/get-started/tezos-taco-shop-smart-contract.md#calculating-the-current-purchase-price) +- check if the sent `amount` matches the `current_purchase_price` + - if not, then our contract will `fail` and stop executing + - if yes, stock for the given `taco_kind` will be decreased and the payment accepted + +**`taco-shop.ligo`** +```Pascal +type taco_supply is record + current_stock : nat; + max_price : tez; +end +type taco_shop_storage is map(nat, taco_supply); + +function buy_taco (const taco_kind_index: nat ; var taco_shop_storage : taco_shop_storage) : (list(operation) * taco_shop_storage) is + begin + // Retrieve the taco_kind from the contract's storage + const taco_kind : taco_supply = get_force(taco_kind_index, taco_shop_storage); + + const current_purchase_price : tez = taco_kind.max_price / taco_kind.current_stock; + + if amount =/= current_purchase_price then + // we won't sell tacos if the amount isn't correct + fail("Sorry, the taco you're trying to purchase has a different price"); + else + // Decrease the stock by 1n, because we've just sold one + taco_kind.current_stock := abs(taco_kind.current_stock - 1n); + + // Update the storage with the refreshed taco_kind + taco_shop_storage[taco_kind_index] := taco_kind; + end with ((nil : list(operation)), taco_shop_storage) +``` + +In order to test the `amount` sent, we'll use the `--amount` option of `dry-run`: + +```zsh +ligo dry-run taco-shop.ligo --syntax pascaligo --amount 1 buy_taco 1n "map + 1n -> record + current_stock = 50n; + max_price = 50000000mtz; + end; + 2n -> record + current_stock = 20n; + max_price = 75000000mtz; + end; +end" +``` +**Purchasing a taco with 1.0tz** + +
Stock decreases after selling a taco, if the right amount of tezzies is provided
+ +
+ +**Attempting to purchase a taco with 0.7tz** + +
Stock does not decrease after a purchase attempt with a lower than required amount.
+ +
+ +**That's it - Pedro can now sell tacos on-chain, thanks to Tezos & LIGO.** + +--- + +## 💰 Bonus: *Accepting tips above the taco purchase price* + +If you'd like to accept tips in your contract as well, simply change the following line, depending on which behavior do you prefer. + +**Without tips** +```Pascal +if amount =/= current_purchase_price then +``` + +**With tips** +```Pascal +if amount >= current_purchase_price then +``` diff --git a/gitlab-pages/website/blog/2019-06-07-introducing-ligo.md b/gitlab-pages/website/blog/2019-06-07-introducing-ligo.md deleted file mode 100644 index db0688724..000000000 --- a/gitlab-pages/website/blog/2019-06-07-introducing-ligo.md +++ /dev/null @@ -1,6 +0,0 @@ ---- -title: Introducing LIGO -author: Matej Sima ---- - -Hello LIGO diff --git a/gitlab-pages/website/blog/2019-06-13-public-launch-of-ligo.md b/gitlab-pages/website/blog/2019-06-13-public-launch-of-ligo.md new file mode 100644 index 000000000..f0caa55b8 --- /dev/null +++ b/gitlab-pages/website/blog/2019-06-13-public-launch-of-ligo.md @@ -0,0 +1,102 @@ +--- +title: Public Launch of LIGO +author: Gabriel Alfour +--- + +# Public Launch of [LIGO](https://ligolang.org/) + +--- + +## A Refresher: What is LIGO? +LIGO is a statically typed high-level smart-contract language that compiles down to Michelson. It seeks to be easy to use, extensible and safe. + +The core language is being developed by The Marigold Project. George Dupéron and Christian Rinderknecht of Nomadic Labs help on the core language, and tooling for LIGO is being developed by Stove Labs (Granary, docs and infrastructure) and Brice Aldrich (syntax highlighting). + +Our previous Medium posts about LIGO can be found [here](https://medium.com/tezos/introducing-ligo-a-new-smart-contract-language-for-tezos-233fa17f21c7) and [here](https://medium.com/tezos/ligo-becomes-polyglot-a474e2cb0c24). + +## The State of LIGO +Today, we are publicly releasing LIGO in beta\*. We've focused on making the onboarding process for LIGO as painless as possible and encourage you to check out our [tutorials](/docs/tutorials/get-started/tezos-taco-shop-smart-contract) and [documentation](https://ligolang.org/docs/next/setup/installation). + +We are fixing bugs and adding features to LIGO (e.g. some Michelson primitives like iterators are missing) by the day. Please submit issues about bugs and missing features you need when you encounter them, and you just might find those solved in the following week. + +We have been also working to extend the capabilities of Michelson, benefitting all languages (e.g. SmartPy) in the Tezos ecosystem. These proposed changes include adding multiple entrypoints, partial application (enabling cheap closures) and new operators for fast stack access to Michelson. We will submit these improvements with Nomadic Labs and Cryptium in an amendment planned for the next proposal period. + +## Sample Contract + +Here are two samples equivalent contracts written in two different syntaxes. They add or substract an amount to the storage depending on the parameter. + +```pascal +// Pascaligo syntax +type action is +| Increment of int +| Decrement of int + +function main (const p : action ; const s : int) : (list(operation) * int) is + block {skip} with ((nil : list(operation)), + case p of + | Increment(n) -> s + n + | Decrement(n) -> s - n + end) +``` + +```ocaml +(* Cameligo syntax *) +type action = +| Increment of int +| Decrement of int + +let main (p : action) (s : int) : (operation list * int) = + let storage = + match p with + | Increment n -> s + n + | Decrement n -> s - n in + (([] : operation list) , storage) +``` + +## Roadmap + +### Short-Term +#### June 2019 +✓ First public release (hi) +✓ PascaLIGO and CameLIGO +✓ Docs +✓ Tutorials +\- Integration testing in JS/Reason with [Granary](https://stove-labs.github.io/granary/) + +#### July 2019 +\- Try ligo online +\- Unit testing in LIGO +\- ReasonLIGO (ReasonML syntax) +\- Design Pattern repository + +### Mid-Term +We are currently planning 3 big projects on the core language (excluding tooling). + +#### Generic Front End (GFE) +The PascaLIGO and CameLIGO parsers, pretty-printers and highlighters were written by hand. The same will be done for the ReasonML syntax in July. +The Generic Front End is a project to alleviate the need to do this manually for future syntaxes. The idea of the GFE is to develop a system that can take in a syntax description, and then generate: +- A parser +- A displayer +- A transpiler between syntaxes +- A syntax highlighter +- Some documentation + +(A prototoype can be found in the code base that generated a PrettyPrinter, a Parser and an AST.) + +#### Super Type System (STS) +The current type system is very basic: it is structural, non-polymorphic, without subtyping, names, references, advanced inference or effects. We are planning to change that. +We are looking to develop a Super Type System that has the following features: +- A rich type system. We are planning to integrate standard features (polymorphism, names), clear error messages and intuitive type inference. +- An effect system. This is important to capture failure cases, write effects in an idiomatic yet safe style (rather than passing around the storage through function calls) or capture which contracts can be called. +- An easy-to-use API. We want people to easily build static analysis tools on top of LIGO. + +#### Real-time Benchmark + +The current version explicitly excludes non-essential features which can produce unexpected explosions in gas costs. To alleviate this constraint, we plan to integrate gas benchmarks on all top-level declarations with some fuzzing. This will allow developers and users to estimate the cost of their contracts in real time. + +## Getting Started and Contact +Come visit [our website](ligolang.org)! You can also join our [Discord](https://discord.gg/CmTwFM), Riot (*#ligo-public:matrix.org*) or Telegram Chat (Ligo Public channel). + + + +\* Following software release cycle conventions, it should be called a pre-alpha. But most people don't know the difference. diff --git a/gitlab-pages/website/blog/2019-07-11-ligo-update.md b/gitlab-pages/website/blog/2019-07-11-ligo-update.md new file mode 100644 index 000000000..1782b7731 --- /dev/null +++ b/gitlab-pages/website/blog/2019-07-11-ligo-update.md @@ -0,0 +1,59 @@ +--- +title: Updates about LIGO and Marigold +author: Gabriel Alfour +--- + +# Updates about LIGO and Marigold + +--- + +It's been a few weeks since our last update. Since then, we've onboarded new collaborators to both LIGO and Marigold, rewritten much of the codebase, and we've begun some exciting new projects. Let's tell you all about it! + +# LIGO + +Now that we've expanded the team, LIGO is progressing faster! Since our last update, we've published some initial tutorials, streamlined the installation process, and added new features to LIGO. + +Our ongoing efforts focus on removing the "warts" of LIGO, i.e. the aspects of LIGO which remain incomplete or unpleasant. Once finished, we will communicate much more extensively about LIGO, how developers can get started, and integrate with popular developer tools. + +We are also working on some longer-term projects which we highlight below. + +## Generic Front End + +LIGO currently supports 2 syntaxes, but that support is clunky and unscaleable to maintain in the long-run. For example, adding a new operator requires us to add it to both syntaxes manually and adding a new syntax remains time-consuming and compounds technical debt. + +As such, we are working on a Generic Front End (GFE), so that it becomes much easier to add syntaxes to LIGO and add new features to all syntaxes at once. The GFE also aims to support seamless translation between the syntaxes, so that one can not only write code in any syntax, but also read code written by other people in the syntax of their choice! + +To attract Ethereum developers, we are also looking at supporting the syntax of [Yul, an intermediary language between Solidity and the EVM](https://solidity.readthedocs.io/en/v0.5.3/yul.html), which would be a big step in supporting contracts written in Solidity! + +## Super Type System + +LIGO currently has a very simple type-system, requiring some extraneous type annotations and forbidding a lot of harmless programs. + +To fix this, we are putting effort into developing a Super Type System (STS). A more comprehensive type system will also help us to natively support Yul and constructs coming from other popular languages. + +Coming at this from the other end, the STS will make it much easier for developers to integrate tools and static analysis into LIGO. + +## Formally Verified Backend + +The most brittle part of our code base is about to become its strongest part. We are currently rewriting the backend of LIGO in Coq, and partially proving its correctness along the way. + +**The significance of this effort can't be stressed enough.** Basically, once we prove the equivalence between a part of LIGO and its Michelson counterpart, we can safely trust it. + +Concretely: +- Running LIGO-in-Browser will become much easier. Instead of having to dry-run it remotely or to rewrite a Michelson interpreter, we'll be able to **directly interpret** the LIGO program. +- It will be possible to prove the properties of Smart-Contracts written in LIGO directly, instead of having to prove the Michelson they produce. +- Fewer tests will ned to be written and testing will instead focus mostly on the developer-facing layers of the compiler (i.e. syntax, typing), rather than on the actual compiling part. + +# Marigold + +We had slowed development on Marigold until LIGO was ready. While we are still knocking out LIGO's remaining warts, we are finally returning our eyes back to Marigold. + +Tangibly speaking, we are locking down some actual implementation details with new collaborators and hope to provide an update in the coming weeks. + +On the more theoretical side, we are also working on a mathematical presentation of Plasma. Although there has been a tremendous amount of innovation and tinkering in the Plasma space, current writings about Plasma are very informal and lack mathematical specification. + +It is thus hard for newcomers (even CS researchers!) to dive into Plasma in a common way. It can also be hard to evaluate new ideas in this space, because each Plasma project brings their own jargon, assumptions, and models of how these systems work. Once this is done, we will strive to make Plasma General even more General. + +# Contact + +If you have any question, feel free to visit [our website](ligolang.org) and to contact us :) diff --git a/gitlab-pages/website/core/Footer.js b/gitlab-pages/website/core/Footer.js index 0ed63ce47..4a1fa9bc5 100644 --- a/gitlab-pages/website/core/Footer.js +++ b/gitlab-pages/website/core/Footer.js @@ -37,6 +37,9 @@ class Footer extends React.Component { Contribute + + Api Documentation +
Community
@@ -56,7 +59,7 @@ class Footer extends React.Component {
More
Blog - Tutorials + Tutorials Gitlab
diff --git a/gitlab-pages/website/pages/en/index.js b/gitlab-pages/website/pages/en/index.js index 5e395c5dd..77a161104 100644 --- a/gitlab-pages/website/pages/en/index.js +++ b/gitlab-pages/website/pages/en/index.js @@ -32,7 +32,7 @@ class HomeSplash extends React.Component { data-tab="tab-group-3-content-4">PascaLIGO
CameLIGO
-
Reasonligo (coming soon)
+
ReasonLIGO (coming soon)
{/*
Camligo
*/} @@ -40,7 +40,7 @@ class HomeSplash extends React.Component {
- 
// variant defining pseudo multi-entrypoint actions
type action is
| Increment of int
| Decrement of int

function add (const a : int ; const b : int) : int is
    block {'{ skip }'} with a + b

function subtract (const a : int ; const b : int) : int is
    block {'{ skip }'} with a - b

// real entrypoint that re-routes the flow based on the action provided
function main (const p : action ; const s : int) : (list(operation) * int) is
  block {'{ skip }'} with ((nil : list(operation)),
    case p of
    | Increment n -> add(s, n)
    | Decrement n -> subtract(s, n)
    end)
+ 
// variant defining pseudo multi-entrypoint actions
type action is
| Increment of int
| Decrement of int

function add (const a : int ; const b : int) : int is
    block {'{ skip }'} with a + b

function subtract (const a : int ; const b : int) : int is
    block {'{ skip }'} with a - b

// real entrypoint that re-routes the flow based on the action provided
function main (const p : action ; const s : int) : (list(operation) * int) is
  block {'{ skip }'} with ((nil : list(operation)),
    case p of
    | Increment(n) -> add(s, n)
    | Decrement(n) -> subtract(s, n)
    end)
@@ -95,8 +95,8 @@ class HomeSplash extends React.Component {
- - + +
diff --git a/gitlab-pages/website/sidebars.json b/gitlab-pages/website/sidebars.json index 0276684dd..3f80e2e51 100644 --- a/gitlab-pages/website/sidebars.json +++ b/gitlab-pages/website/sidebars.json @@ -16,6 +16,6 @@ "Road Map": ["contributors/road-map/short-term", "contributors/road-map/long-term"] }, "tutorials": { - "Get Started": ["tutorials/first-smart-contract"] + "Get Started": ["tutorials/get-started/tezos-taco-shop-smart-contract", "tutorials/get-started/tezos-taco-shop-payout"] } } diff --git a/gitlab-pages/website/siteConfig.js b/gitlab-pages/website/siteConfig.js index 0f98c67e8..34a273ecc 100644 --- a/gitlab-pages/website/siteConfig.js +++ b/gitlab-pages/website/siteConfig.js @@ -98,10 +98,12 @@ const siteConfig = { // For no header links in the top nav bar -> headerLinks: [], headerLinks: [ {doc: 'setup/installation', label: 'Docs'}, - {doc: 'api-cli-commands', label: 'CLI'}, - {doc: 'tutorials/first-smart-contract', label: 'Tutorials'}, + {doc: 'tutorials/get-started/tezos-taco-shop-smart-contract', label: 'Tutorials'}, { blog: true, label: 'Blog' }, + // TODO: { href: "/odoc", label: "Api" }, {doc: 'contributors/origin', label: 'Contribute'}, + {href: 'https://discord.gg/9rhYaEt', label: ''}, + { search: true }, ], // If you have users set above, you add it here: @@ -162,6 +164,12 @@ const siteConfig = { // You may provide arbitrary config keys to be used as needed by your // template. For example, if you need your repo's URL... repoUrl: 'https://gitlab.com/ligolang/ligo', + + algolia: { + apiKey: '12be98d9fd4242a5f16b70a5cc6b0158', + indexName: 'ligolang', + algoliaOptions: {} // Optional, if provided by Algolia + }, }; module.exports = siteConfig; diff --git a/gitlab-pages/website/static/.well-known/acme-challenge/pY4yiss3_bmzORHLtOPUEYaFxWxD_GkD8XZajWh0DUU b/gitlab-pages/website/static/.well-known/acme-challenge/pY4yiss3_bmzORHLtOPUEYaFxWxD_GkD8XZajWh0DUU new file mode 100644 index 000000000..d17cdcfbe --- /dev/null +++ b/gitlab-pages/website/static/.well-known/acme-challenge/pY4yiss3_bmzORHLtOPUEYaFxWxD_GkD8XZajWh0DUU @@ -0,0 +1 @@ +pY4yiss3_bmzORHLtOPUEYaFxWxD_GkD8XZajWh0DUU.4Dc00ftieGaWDmacztwSS7euFOKPULDHjUNzikwPvao diff --git a/gitlab-pages/website/static/css/custom.css b/gitlab-pages/website/static/css/custom.css index 32e965faa..7f643b6e2 100644 --- a/gitlab-pages/website/static/css/custom.css +++ b/gitlab-pages/website/static/css/custom.css @@ -86,7 +86,7 @@ blockquote { } blockquote code { - opacity: 0.7; + opacity: 0.5; } /* blockquote a { @@ -211,6 +211,27 @@ code { color: #444; } +body > div.fixedHeaderContainer > div > header > div > nav > ul > li:nth-child(5) { + background: url('/img/discord.svg'); + background-repeat: no-repeat; + background-position: center center; + min-width: 50px; + padding-top: 5px; + opacity: 0.8; +} + +body > div.fixedHeaderContainer > div > header > div > nav > ul > li:nth-child(5):hover { + opacity: 1; +} + +body > div.fixedHeaderContainer > div > header > div > nav > ul > li:nth-child(5) > a:hover { + background: transparent; +} + +.cheatsheet tr > td:first-of-type { + min-width: 240px; +} + @media only screen and (min-device-width: 360px) and (max-device-width: 736px) { } diff --git a/gitlab-pages/website/static/img/discord.svg b/gitlab-pages/website/static/img/discord.svg new file mode 100644 index 000000000..4613aa9ae --- /dev/null +++ b/gitlab-pages/website/static/img/discord.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-payout/dry-run-1.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-payout/dry-run-1.png new file mode 100644 index 000000000..a8930f63f Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-payout/dry-run-1.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-payout/get-money.svg b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-payout/get-money.svg new file mode 100644 index 000000000..117937d25 --- /dev/null +++ b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-payout/get-money.svg @@ -0,0 +1,55 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-1.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-1.png new file mode 100644 index 000000000..e685074fc Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-1.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-2.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-2.png new file mode 100644 index 000000000..6f5c902e0 Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-2.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-3.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-3.png new file mode 100644 index 000000000..5eb717885 Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-3.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-4.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-4.png new file mode 100644 index 000000000..6ee09b118 Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-4.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-5.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-5.png new file mode 100644 index 000000000..ac390ce9c Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/dry-run-5.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/install-ligo.png b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/install-ligo.png new file mode 100644 index 000000000..ca3364820 Binary files /dev/null and b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/install-ligo.png differ diff --git a/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/taco-stand.svg b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/taco-stand.svg new file mode 100644 index 000000000..c09c0283d --- /dev/null +++ b/gitlab-pages/website/static/img/tutorials/get-started/tezos-taco-shop-smart-contract/taco-stand.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/gitlab-pages/website/versioned_sidebars/version-next-sidebars.json b/gitlab-pages/website/versioned_sidebars/version-next-sidebars.json index 8e143da9e..874a99889 100644 --- a/gitlab-pages/website/versioned_sidebars/version-next-sidebars.json +++ b/gitlab-pages/website/versioned_sidebars/version-next-sidebars.json @@ -37,7 +37,7 @@ }, "version-next-tutorials": { "Get Started": [ - "version-next-tutorials/first-smart-contract" + "version-next-tutorials/get-started/tezos-taco-shop-smart-contract" ] } } diff --git a/scripts/build_docker_image.sh b/scripts/build_docker_image.sh index eb2bdb611..273fa92c6 100755 --- a/scripts/build_docker_image.sh +++ b/scripts/build_docker_image.sh @@ -1 +1,4 @@ -docker build -t ligolang/ligo -f docker/Dockerfile . \ No newline at end of file +#!/bin/sh +set -e + +docker build -t ligolang/ligo -f docker/Dockerfile . diff --git a/scripts/install_ligo_with_dependencies.sh b/scripts/install_ligo_with_dependencies.sh index 9ad969f3f..78e5d8b62 100755 --- a/scripts/install_ligo_with_dependencies.sh +++ b/scripts/install_ligo_with_dependencies.sh @@ -1 +1,5 @@ -cd src && opam install . --yes \ No newline at end of file +#!/bin/sh +set -e + +cd src +opam install . --yes diff --git a/scripts/install_native_dependencies.sh b/scripts/install_native_dependencies.sh index 04d4ce17f..6b06f51ad 100755 --- a/scripts/install_native_dependencies.sh +++ b/scripts/install_native_dependencies.sh @@ -1,7 +1,14 @@ -apt-get -y install \ +#!/bin/sh +set -e + +apt-get update -qq +apt-get -y -qq install \ libev-dev \ perl \ pkg-config \ libgmp-dev \ libhidapi-dev \ - m4 \ No newline at end of file + m4 \ + libcap-dev \ + bubblewrap \ + rsync diff --git a/scripts/install_opam.sh b/scripts/install_opam.sh new file mode 100755 index 000000000..1a89f6a9b --- /dev/null +++ b/scripts/install_opam.sh @@ -0,0 +1,10 @@ +#!/bin/sh +set -e + +# TODO: this has many different modes of failure (file temp.opam-2.0.1-x86_64-linux.download-in-progress already exists, /usr/local/bin/opam already exists and is a directory or hard link, …) +# Try to improve these aspects. + +wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O temp.opam-2.0.1-x86_64-linux.download-in-progress +cp -i temp.opam-2.0.1-x86_64-linux.download-in-progress /usr/local/bin/opam +chmod +x /usr/local/bin/opam +rm temp.opam-2.0.1-x86_64-linux.download-in-progress diff --git a/scripts/installer.sh b/scripts/installer.sh index 7486f5a0f..c8623c6a7 100755 --- a/scripts/installer.sh +++ b/scripts/installer.sh @@ -1,31 +1,96 @@ -#!/bin/bash +#!/bin/sh +set -e + # You can run this installer like this: # curl https://gitlab.com/ligolang/ligo/blob/master/scripts/installer.sh | bash -# Make sure the marigold/ligo image is published at docker hub first -set -euET -o pipefail -version=$1 -printf "\nInstalling LIGO ($version)\n\n" +# Make sure the marigold/ligo image is published at docker hub first -if [ $version = "next" ] - then - # Install the ligo.sh from master - wget https://gitlab.com/ligolang/ligo/raw/dev/scripts/ligo.sh - else - # Install the ligo.sh from master - wget https://gitlab.com/ligolang/ligo/raw/master/scripts/ligo.sh +if test $# -ne 1; then + printf 'Usage: installer.sh VERSION'\\n + printf \\n + printf ' where VERSION can be "next" or a version number like 1.0.0'\\n + exit 1 +else + version=$1 + printf \\n'Installing LIGO (%s)'\\n\\n "$version" + + if [ $version = "next" ] + then + # Install the ligo.sh from master + url=https://gitlab.com/ligolang/ligo/raw/dev/scripts/ligo.sh + else + # Install the ligo.sh from master + url=https://gitlab.com/ligolang/ligo/raw/master/scripts/ligo.sh + fi + + # Pull the docker image used by ligo.sh + docker pull "ligolang/ligo:$version" + + # Install ligo.sh + # Rationale behind this part of the script: + # * mv is one of the few commands which is atomic + # * therefore we will create a file with the desired contents, and if that works, atomically mv it. + # If something goes wrong it will attempt to remove the temporary file + # (if removing the temporary file fails it's not a big deal due to the fairly explicit file name, + # the fact that it is hidden, and its small size) + # * most utilities (e.g. touch) don't explicitly state that they support umask in their man page + # * therefore we try to set the mode for the temporary file with an umask + do a chmod just to be sure + # * this leaves open a race condition where: + # 0) umask isn't applied by touch (e.g. the file already exists) + # 1) for some reason touch creates an executable file (e.g. the file already exists) + # 2) a user grabs the file while it is executable, and triggers its execution (the process is created but execution of the script doesn't start yet) + # 3) chmod makes it non-executable + # 4) the file is partially written + # 5) the execution actually starts, and executes a prefix of the desired command, and that prefix is usable for adverse effects + # To mitigate this, we wrap the command in the script with + # if true; then the_command; fi + # That way, the shell will raise an error due to a missing "fi" if the script executed while it is partially written + # * This still leaves open the same race condition where a propper prefix of #!/bin/sh\nif can be used to adverse effect, but there's not much we can do about this. + # * after the file is completely written, we make it executable + # * we then check for the cases where `mv` misbehaves + # * we then atomically move it to (hopefully) its destination + # * the main risks here are if /usr/local/bin/ is writable by hostile users on the same machine (then there are bigger problems than what is our concern) + # or if root itself tries to create a race condition (then there are bigger problems than what is our concern) + + # It's hard to place comments inside a sequence of commands, so here are the comments for the following code: + # wget download to stdout + # | sudo become root (sudo) for the rest of the commands + # ( subshell (to clean up temporary file if anything goes wrong) + # remove temporary file in case it already exists + # && create temporary file with (hopefully) the right permissions + # && fix permisisons in case the creation didn't take umask into account + # && redirect the output of the wget download to the temporary file + # ) || clean up temporary file if any command in the previous block failed + + wget "$url" -O - \ + | sed -e "s/next/$version/g" \ + | sudo sh -c ' \ + ( \ + rm -f /usr/local/bin/.temp.ligo.before-atomic-move \ + && (umask 0600 > /dev/null 2>&1; UMASK=0600 touch /usr/local/bin/.temp.ligo.before-atomic-move) \ + && chmod 0600 /usr/local/bin/.temp.ligo.before-atomic-move \ + && cat > /usr/local/bin/.temp.ligo.before-atomic-move \ + ) || (rm /usr/local/bin/.temp.ligo.before-atomic-move; exit 1)' + + # sudo become root (sudo) for the rest of the commands + # ( subshell (to clean up temporary file if anything goes wrong) + # && check that the download seems complete (one can't rely on sigpipe & failures to correctly stop the sudo session in case the download fails) + # && overwite LIGO version in the executable + # && now that the temporary file is complete, make it executable + # && if check for some corner cases: destination exists and is a directory + # elif check for some corner cases: destination exists and is symbolic link + # else atomically (hopefully) move temporary file to its destination + # ) || clean up temporary file if any command in the previous block failed + + sudo sh -c ' \ + ( \ + grep "END OF DOWNLOADED FILE" /usr/local/bin/.temp.ligo.before-atomic-move \ + && chmod 0755 /usr/local/bin/.temp.ligo.before-atomic-move \ + && if test -d /usr/local/bin/ligo; then printf "/usr/local/bin/ligo already exists and is a directory, cancelling installation"'\\\\'n; rm /usr/local/bin/.temp.ligo.before-atomic-move; \ + elif test -L /usr/local/bin/ligo; then printf "/usr/local/bin/ligo already exists and is a symbolic link, cancelling installation"'\\\\'n; rm /usr/local/bin/.temp.ligo.before-atomic-move; \ + else mv -i /usr/local/bin/.temp.ligo.before-atomic-move /usr/local/bin/ligo; fi \ + ) || (rm /usr/local/bin/.temp.ligo.before-atomic-move; exit 1)' + + # Installation finished, try running 'ligo' from your CLI + printf \\n'Installation successful, try to run '\''ligo --help'\'' now.'\\n fi - - -# Overwrite LIGO version in the executable -sed -i '' "s/latest/$version/g" ligo.sh - -# Copy the exucutable to the appropriate directory -sudo cp ligo.sh /usr/local/bin/ligo -sudo chmod +x /usr/local/bin/ligo -rm ligo.sh - -# Pull the docker image used by ligo.sh -docker pull "ligolang/ligo:$version" - -# Installation finished, try running 'ligo' from your CLI -printf "\nInstallation successful, try to run 'ligo --help' now.\n" \ No newline at end of file diff --git a/scripts/ligo.sh b/scripts/ligo.sh index 8ccadad8e..236ebe98f 100755 --- a/scripts/ligo.sh +++ b/scripts/ligo.sh @@ -1,2 +1,10 @@ -#!/bin/bash -docker run -it -v "$PWD":"$PWD" -w "$PWD" ligolang/ligo:latest "$@" \ No newline at end of file +#!/bin/sh +set -e +if test "x$PWD" = "x"; then + echo "Cannot detect the current directory, the environment variable PWD is empty." + exit 1 +else + docker run -it -v "$PWD":"$PWD" -w "$PWD" ligolang/ligo:next "$@" +fi +# Do not remove the next line. It is used as an approximate witness that the download of this file was complete. This string should not appear anywhere else in the file. +# END OF DOWNLOADED FILE diff --git a/scripts/setup_ligo_opam_repository.sh b/scripts/setup_ligo_opam_repository.sh index e07eac487..444aee6d5 100755 --- a/scripts/setup_ligo_opam_repository.sh +++ b/scripts/setup_ligo_opam_repository.sh @@ -1,3 +1,6 @@ +#!/bin/sh +set -e + vendors/opam-repository-tools/rewrite-local-opam-repository.sh opam repo add ligo-opam-repository ./vendors/ligo-opam-repository-local-generated -opam update ligo-opam-repository \ No newline at end of file +opam update ligo-opam-repository diff --git a/src/TODO.txt b/src/TODO.txt deleted file mode 100644 index 210cb0637..000000000 --- a/src/TODO.txt +++ /dev/null @@ -1,21 +0,0 @@ -# Main - -## Back-end - -- Replace Mini_c environments with stacks - + Compiler_environment : bad pack make first element deepest - + Add types to pack and unpack -- Think about Coq - -## Amendments - -- Bubble_n -- Partial application -- Type size limit (1.000 -> 10.000) - -# PPX - -## Deriving - -- Generate ADT helpers (this removes 90% of Combinators and a lot of maintenance when modifying ASTs) -- Generate option helpers (this makes writing main much easier, much like one would in an untyped language) diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index e136988d2..07277c664 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -24,6 +24,7 @@ let literal ppf (l:literal) = match l with | 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_tez n -> fprintf ppf "%dtz" n | Literal_string s -> fprintf ppf "%S" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b @@ -41,6 +42,7 @@ let rec expression ppf (e:expression) = match Location.unwrap e with | E_record m -> fprintf ppf "record[%a]" (smap_sep_d expression) m | E_map m -> fprintf ppf "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" diff --git a/src/ast_simplified/ast_simplified.ml b/src/ast_simplified/ast_simplified.ml index 566e95155..f2eca5152 100644 --- a/src/ast_simplified/ast_simplified.ml +++ b/src/ast_simplified/ast_simplified.ml @@ -1,5 +1,5 @@ include Types -include Misc +(* include Misc *) include Combinators module Types = Types diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index 690c9dfcb..e130e033c 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -4,6 +4,17 @@ module Option = Simple_utils.Option module SMap = Map.String +module Errors = struct + let bad_kind expected location = + let title () = Format.asprintf "a %s was expected" expected in + let message () = "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title message +end +open Errors + let t_bool : type_expression = T_constant ("bool", []) let t_string : type_expression = T_constant ("string", []) let t_bytes : type_expression = T_constant ("bytes", []) @@ -32,6 +43,7 @@ let ez_t_sum (lst:(string * type_expression) list) : type_expression = let t_function param result : type_expression = T_function (param, result) let t_map key value = (T_constant ("map", [key ; value])) +let t_set key = (T_constant ("set", [key])) let make_name (s : string) : name = s @@ -40,6 +52,7 @@ let e_literal ?loc l : expression = Location.wrap ?loc @@ E_literal l let e_unit ?loc () : expression = Location.wrap ?loc @@ E_literal (Literal_unit) let e_int ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_int n) let e_nat ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_nat n) +let e_timestamp ?loc n : expression = Location.wrap ?loc @@ E_literal (Literal_timestamp n) let e_bool ?loc b : expression = Location.wrap ?loc @@ E_literal (Literal_bool b) let e_string ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_string s) let e_address ?loc s : expression = Location.wrap ?loc @@ E_literal (Literal_address s) @@ -51,6 +64,7 @@ let e_some ?loc s : expression = Location.wrap ?loc @@ E_constant ("SOME", [s]) let e_none ?loc () : expression = Location.wrap ?loc @@ E_constant ("NONE", []) let e_map_add ?loc k v old : expression = Location.wrap ?loc @@ E_constant ("MAP_ADD" , [k ; v ; old]) let e_map ?loc lst : expression = Location.wrap ?loc @@ E_map lst +let e_set ?loc lst : expression = Location.wrap ?loc @@ E_set lst let e_list ?loc lst : expression = Location.wrap ?loc @@ E_list lst let e_pair ?loc a b : expression = Location.wrap ?loc @@ E_tuple [a; b] let e_constructor ?loc s a : expression = Location.wrap ?loc @@ E_constructor (s , a) @@ -91,6 +105,8 @@ let e_typed_list ?loc lst t = let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v) +let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) + let e_lambda ?loc (binder : string) (input_type : type_expression option) (output_type : type_expression option) @@ -132,7 +148,7 @@ let get_e_pair = fun t -> let get_e_list = fun t -> match t with | E_list lst -> ok lst - | _ -> simple_fail "not a pair" + | _ -> simple_fail "not a list" let get_e_failwith = fun e -> match Location.unwrap e with @@ -140,3 +156,23 @@ let get_e_failwith = fun e -> | _ -> simple_fail "not a failwith" let is_e_failwith e = to_bool @@ get_e_failwith e + +let extract_pair : expression -> (expression * expression) result = fun e -> + match Location.unwrap e with + | E_tuple [ a ; b ] -> ok (a , b) + | _ -> fail @@ bad_kind "pair" e.location + +let extract_list : expression -> (expression list) result = fun e -> + match Location.unwrap e with + | E_list lst -> ok lst + | _ -> fail @@ bad_kind "list" e.location + +let extract_record : expression -> (string * expression) list result = fun e -> + match Location.unwrap e with + | E_record lst -> ok @@ SMap.to_kv_list lst + | _ -> fail @@ bad_kind "record" e.location + +let extract_map : expression -> (expression * expression) list result = fun e -> + match Location.unwrap e with + | E_map lst -> ok lst + | _ -> fail @@ bad_kind "map" e.location diff --git a/src/ast_simplified/misc.ml b/src/ast_simplified/misc.ml index c857b8072..e1582b073 100644 --- a/src/ast_simplified/misc.ml +++ b/src/ast_simplified/misc.ml @@ -42,6 +42,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_nat a, Literal_nat b when a = b -> ok () | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b + | Literal_timestamp a, Literal_timestamp b when a = b -> ok () + | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b + | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b | Literal_tez a, Literal_tez b when a = b -> ok () | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b @@ -59,7 +62,6 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b - let rec assert_value_eq (a, b: (expression * expression )) : unit result = let error_content () = Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b @@ -143,6 +145,19 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = ) | E_list _, _ -> simple_fail "comparing list with other stuff" + + | 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 stuff" + | (E_annotation (a , _) , _b') -> assert_value_eq (a , b) | (_a' , E_annotation (b , _)) -> assert_value_eq (a , b) | (E_variable _, _) | (E_lambda _, _) @@ -151,6 +166,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_look_up _, _) | (E_matching _, _) | (E_failwith _, _) | (E_sequence _, _) | (E_loop _, _) | (E_assign _, _) | (E_skip, _) -> simple_fail "comparing not a value" +let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) (* module Rename = struct * open Trace diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index 4693546b8..3eb0990cb 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -60,6 +60,7 @@ and expression' = (* Data Structures *) | E_map of (expr * expr) list | E_list of expr list + | E_set of expr list | E_look_up of (expr * expr) (* Matching *) | E_matching of (expr * matching_expr) @@ -90,6 +91,7 @@ and literal = | Literal_string of string | Literal_bytes of bytes | Literal_address of string + | Literal_timestamp of int | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation and 'a matching = diff --git a/src/ast_typed/PP.ml b/src/ast_typed/PP.ml index 4c2122fa8..3e8edf30c 100644 --- a/src/ast_typed/PP.ml +++ b/src/ast_typed/PP.ml @@ -43,6 +43,7 @@ and expression ppf (e:expression) : unit = | E_record m -> fprintf ppf "record[%a]" (smap_sep_d annotated_expression) m | E_map m -> fprintf ppf "map[@; @[%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m | E_list m -> fprintf ppf "list[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m + | E_set m -> fprintf ppf "set[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) m | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i | E_matching (ae, m) -> fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m @@ -68,6 +69,7 @@ and literal ppf (l:literal) : unit = | 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_tez n -> fprintf ppf "%dtz" n | Literal_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index a6d34c72a..ec745fabc 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -15,6 +15,8 @@ let make_n_t type_name type_value = { type_name ; type_value } let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s let t_string ?s () : type_value = make_t (T_constant ("string", [])) s let t_bytes ?s () : type_value = make_t (T_constant ("bytes", [])) s +let t_key ?s () : type_value = make_t (T_constant ("key", [])) s +let t_key_hash ?s () : type_value = make_t (T_constant ("key_hash", [])) s let t_int ?s () : type_value = make_t (T_constant ("int", [])) s let t_address ?s () : type_value = make_t (T_constant ("address", [])) s let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s @@ -25,6 +27,7 @@ let t_unit ?s () : type_value = make_t (T_constant ("unit", [])) s let t_option o ?s () : type_value = make_t (T_constant ("option", [o])) s let t_tuple lst ?s () : type_value = make_t (T_tuple lst) s let t_list t ?s () : type_value = make_t (T_constant ("list", [t])) s +let t_set t ?s () : type_value = make_t (T_constant ("set", [t])) s let t_contract t ?s () : type_value = make_t (T_constant ("contract", [t])) s let t_pair a b ?s () = t_tuple [a ; b] ?s () @@ -93,6 +96,22 @@ let get_t_list (t:type_value) : type_value result = match t.type_value' with | T_constant ("list", [o]) -> ok o | _ -> simple_fail "not a list" +let get_t_set (t:type_value) : type_value result = match t.type_value' with + | T_constant ("set", [o]) -> ok o + | _ -> simple_fail "not a set" + +let get_t_key (t:type_value) : unit result = match t.type_value' with + | T_constant ("key", []) -> ok () + | _ -> simple_fail "not a key" + +let get_t_signature (t:type_value) : unit result = match t.type_value' with + | T_constant ("signature", []) -> ok () + | _ -> simple_fail "not a signature" + +let get_t_key_hash (t:type_value) : unit result = match t.type_value' with + | T_constant ("key_hash", []) -> ok () + | _ -> simple_fail "not a key_hash" + let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with | T_tuple lst -> ok lst | _ -> simple_fail "not a tuple" @@ -122,6 +141,11 @@ let get_t_map (t:type_value) : (type_value * type_value) result = | T_constant ("map", [k;v]) -> ok (k, v) | _ -> simple_fail "get: not a map" +let get_t_big_map (t:type_value) : (type_value * type_value) result = + match t.type_value' with + | T_constant ("big_map", [k;v]) -> ok (k, v) + | _ -> simple_fail "get: not a big_map" + let get_t_map_key : type_value -> type_value result = fun t -> let%bind (key , _) = get_t_map t in ok key @@ -135,16 +159,22 @@ let assert_t_map = fun t -> ok () let is_t_map = Function.compose to_bool get_t_map +let is_t_big_map = Function.compose to_bool get_t_big_map -let assert_t_tez :type_value -> unit result = get_t_tez +let assert_t_tez : type_value -> unit result = get_t_tez +let assert_t_key = get_t_key +let assert_t_signature = get_t_signature +let assert_t_key_hash = get_t_key_hash let assert_t_list t = let%bind _ = get_t_list t in ok () let is_t_list = Function.compose to_bool get_t_list +let is_t_set = Function.compose to_bool get_t_set let is_t_nat = Function.compose to_bool get_t_nat let is_t_string = Function.compose to_bool get_t_string +let is_t_bytes = Function.compose to_bool get_t_bytes let is_t_int = Function.compose to_bool get_t_int let assert_t_bytes = fun t -> diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index 077f00c0a..091531789 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -155,6 +155,7 @@ module Free_variables = struct | E_record_accessor (a, _) -> self a | E_tuple_accessor (a, _) -> self a | E_list lst -> unions @@ List.map self lst + | E_set lst -> unions @@ List.map self lst | E_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 (a , cs) -> union (self a) (matching_expression b cs) @@ -344,6 +345,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_nat a, Literal_nat b when a = b -> ok () | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b + | Literal_timestamp a, Literal_timestamp b when a = b -> ok () + | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b + | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b | Literal_tez a, Literal_tez b when a = b -> ok () | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b @@ -443,6 +447,15 @@ let rec assert_value_eq (a, b: (value*value)) : unit result = ) | 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_tuple_accessor _, _) | (E_record_accessor _, _) diff --git a/src/ast_typed/misc_smart.ml b/src/ast_typed/misc_smart.ml index 2c56ad89c..0d0e8cd02 100644 --- a/src/ast_typed/misc_smart.ml +++ b/src/ast_typed/misc_smart.ml @@ -77,6 +77,9 @@ module Captured_variables = struct | 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 -> let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in ok @@ unions lst' diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index a1bfd46d3..65524fde8 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -100,6 +100,7 @@ and expression = (* Data Structures *) | E_map of (ae * ae) list | E_list of ae list + | E_set of ae list | E_look_up of (ae * ae) (* Advanced *) | E_matching of (ae * matching_expr) @@ -116,6 +117,7 @@ and literal = | Literal_bool of bool | Literal_int of int | Literal_nat of int + | Literal_timestamp of int | Literal_tez of int | Literal_string of string | Literal_bytes of bytes diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 4c97be407..11777b504 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -1,41 +1,6 @@ open Cmdliner open Trace - -let error_pp out (e : error) = - let open JSON_string_utils in - let message = - let opt = e |> member "message" |> string in - let msg = Option.unopt ~default:"" opt in - if msg = "" - then "" - else ": " ^ msg in - let error_code = - let error_code = e |> member "error_code" in - match error_code with - | `Null -> "" - | _ -> " (" ^ (J.to_string error_code) ^ ")" in - let title = - let opt = e |> member "title" |> string in - Option.unopt ~default:"" opt in - let data = - let data = e |> member "data" in - match data with - | `Null -> "" - | _ -> " " ^ (J.to_string data) ^ "\n" in - let infos = - let infos = e |> member "infos" in - match infos with - | `Null -> "" - | _ -> " " ^ (J.to_string infos) ^ "\n" in - Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos - - -let toplevel x = - match x with - | Trace.Ok ((), annotations) -> ignore annotations; () - | Error ss -> ( - Format.printf "%a%!" error_pp (ss ()) - ) +open Cli_helpers let main = let term = Term.(const print_endline $ const "Ligo needs a command. Do ligo --help") in @@ -45,7 +10,7 @@ let source n = let open Arg in let info = let docv = "SOURCE_FILE" in - let doc = "$(docv) is the path to the .ligo file of the contract." in + let doc = "$(docv) is the path to the .ligo or .mligo file of the contract." in info ~docv ~doc [] in required @@ pos n (some string) None info @@ -57,9 +22,9 @@ let entry_point n = info ~docv ~doc [] in required @@ pos n (some string) (Some "main") info -let expression n = +let expression purpose n = let open Arg in - let docv = "EXPRESSION" in + let docv = purpose ^ "_EXPRESSION" in let doc = "$(docv) is the expression that will be compiled." in let info = info ~docv ~doc [] in required @@ pos n (some string) None info @@ -68,16 +33,24 @@ let syntax = let open Arg in let info = let docv = "SYNTAX" in - let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\" and \"cameligo\". \"pascaligo\" is the default." in + let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\" and \"cameligo\". By default, the syntax is guessed from the extension (.ligo and .mligo, respectively)." in info ~docv ~doc ["syntax" ; "s"] in - value @@ opt string "pascaligo" info + value @@ opt string "auto" info + +let amount = + let open Arg in + let info = + let docv = "AMOUNT" in + let doc = "$(docv) is the amount the dry-run transaction will use." in + info ~docv ~doc ["amount"] in + value @@ opt string "0" info let compile_file = let f source entry_point syntax = toplevel @@ let%bind contract = trace (simple_info "compiling contract to michelson") @@ - Ligo.Run.compile_contract_file source entry_point syntax in + Ligo.Run.compile_contract_file source entry_point (Syntax_name syntax) in Format.printf "%s\n" contract ; ok () in @@ -92,12 +65,12 @@ let compile_parameter = toplevel @@ let%bind value = trace (simple_error "compile-input") @@ - Ligo.Run.compile_contract_parameter source entry_point expression syntax in + Ligo.Run.compile_contract_parameter source entry_point expression (Syntax_name syntax) in Format.printf "%s\n" value; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax) in let cmdname = "compile-parameter" in let docs = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) @@ -107,28 +80,64 @@ let compile_storage = toplevel @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Run.compile_contract_storage source entry_point expression syntax in + Ligo.Run.compile_contract_storage source entry_point expression (Syntax_name syntax) in Format.printf "%s\n" value; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax) in let cmdname = "compile-storage" in let docs = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let dry_run = - let f source entry_point storage input syntax = + let f source entry_point storage input amount syntax = toplevel @@ let%bind output = - Ligo.Run.run_contract source entry_point storage input syntax in + Ligo.Run.run_contract ~amount source entry_point storage input (Syntax_name syntax) in Format.printf "%a\n" Ast_simplified.PP.expression output ; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression 2 $ expression 3 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax) in let cmdname = "dry-run" in let docs = "Subcommand: run a smart-contract with the given storage and input." in (term , Term.info ~docs cmdname) -let () = Term.exit @@ Term.eval_choice main [compile_file ; compile_parameter ; compile_storage ; dry_run ] +let run_function = + let f source entry_point parameter amount syntax = + toplevel @@ + let%bind output = + Ligo.Run.run_function ~amount source entry_point parameter (Syntax_name syntax) in + Format.printf "%a\n" Ast_simplified.PP.expression output ; + ok () + in + let term = + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax) in + let cmdname = "run-function" in + let docs = "Subcommand: run a function with the given parameter." in + (term , Term.info ~docs cmdname) + +let evaluate_value = + let f source entry_point amount syntax = + toplevel @@ + let%bind output = + Ligo.Run.evaluate_value ~amount source entry_point (Syntax_name syntax) in + Format.printf "%a\n" Ast_simplified.PP.expression output ; + ok () + in + let term = + Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax) in + let cmdname = "evaluate-value" in + let docs = "Subcommand: evaluate a given definition." in + (term , Term.info ~docs cmdname) + + +let () = Term.exit @@ Term.eval_choice main [ + compile_file ; + compile_parameter ; + compile_storage ; + dry_run ; + run_function ; + evaluate_value ; + ] diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml new file mode 100644 index 000000000..068f2bf1d --- /dev/null +++ b/src/bin/cli_helpers.ml @@ -0,0 +1,9 @@ +open Trace + +let toplevel x = + match x with + | Trace.Ok ((), annotations) -> ignore annotations; () + | Error ss -> ( + Format.printf "%a%!" Ligo.Display.error_pp (ss ()) + ) + diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index 05c749095..d5734c4e9 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -87,16 +87,20 @@ let add : environment -> (string * type_value) -> michelson result = fun e (_s , ok code -let select : environment -> string list -> michelson result = fun e lst -> +let select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst -> let module L = Logger.Stateful() in let e_lst = let e_lst = Environment.to_list e in let aux selector (s , _) = L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ; match List.mem s selector with - | true -> List.remove_element s selector , true - | false -> selector , false in - let e_lst' = List.fold_map_right aux lst e_lst in + | true -> List.remove_element s selector , keep + | false -> selector , not keep in + let e_lst' = + if rev = keep + then List.fold_map aux lst e_lst + else List.fold_map_right aux lst e_lst + in let e_lst'' = List.combine e_lst e_lst' in e_lst'' in let code = @@ -144,8 +148,8 @@ let clear : environment -> (michelson * environment) result = fun e -> let%bind first_name = trace_option (simple_error "try to clear empty env") @@ List.nth_opt lst 0 in - let%bind code = select e [ first_name ] in - let e' = Environment.select [ first_name ] e in + let%bind code = select ~rev:true e [ first_name ] in + let e' = Environment.select ~rev:true [ first_name ] e in ok (code , e') let pack : environment -> michelson result = fun e -> diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index db8e7936e..aa737a071 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -16,6 +16,26 @@ let get_predicate : string -> type_value -> expression list -> predicate result | Some x -> ok x | None -> ( match s with + | "NONE" -> ( + let%bind ty' = Mini_c.get_t_option ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE + ) + | "NIL" -> ( + let%bind ty' = Mini_c.get_t_list ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL + ) + | "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 + ) + | "UNPACK" -> ( + let%bind ty' = Mini_c.get_t_option ty in + let%bind m_ty = Compiler_type.type_ ty' in + ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK + ) | "MAP_REMOVE" -> let%bind v = match lst with | [ _ ; expr ] -> @@ -52,6 +72,7 @@ let rec translate_value (v:value) : michelson result = match v with | D_bool b -> ok @@ prim (if b then D_True else D_False) | D_int n -> ok @@ int (Z.of_int n) | D_nat n -> ok @@ int (Z.of_int n) + | D_timestamp n -> ok @@ int (Z.of_int n) | D_tez n -> ok @@ int (Z.of_int n) | D_string s -> ok @@ string s | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s) @@ -70,11 +91,16 @@ let rec translate_value (v:value) : michelson result = match v with ok @@ prim ~children:[s'] D_Some | D_map lst -> let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in + let sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in let aux (a, b) = prim ~children:[a;b] D_Elt in - ok @@ seq @@ List.map aux lst' + ok @@ seq @@ List.map aux sorted | D_list lst -> let%bind lst' = bind_map_list translate_value lst in ok @@ seq lst' + | D_set lst -> + let%bind lst' = bind_map_list translate_value lst in + let sorted = List.sort compare lst' in + ok @@ seq sorted | D_operation _ -> simple_fail "can't compile an operation" @@ -82,30 +108,50 @@ and translate_function (content:anon_function) : michelson result = let%bind body = translate_quote_body content in ok @@ seq [ body ] -and translate_expression ?(first=false) (expr:expression) (env:environment) : (michelson * environment) result = +and translate_expression ?push_var_name (expr:expression) (env:environment) : (michelson * environment) result = let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in let error_message () = Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty in - let i_skip = i_push_unit in + (* let i_skip = i_push_unit in *) - let return ?prepend_env ?end_env code = + let return ?prepend_env ?end_env ?(unit_opt = false) code = + let code = + if unit_opt && push_var_name <> None + then seq [code ; i_push_unit] + else code + in let%bind env' = - match (prepend_env , end_env) with - | (Some _ , Some _) -> simple_fail ("two args to return at " ^ __LOC__) - | None , None -> ok @@ Environment.add ("_tmp_expression" , ty) env - | Some prepend_env , None -> + match (prepend_env , end_env , push_var_name) with + | (Some _ , Some _ , _) -> + simple_fail ("two args to return at " ^ __LOC__) + | None , None , None -> + ok @@ Environment.add ("_tmp_expression" , ty) env + | None , None , Some push_var_name -> + ok @@ Environment.add (push_var_name , ty) env + | Some prepend_env , None , None -> ok @@ Environment.add ("_tmp_expression" , ty) prepend_env - | None , Some end_env -> ok end_env in + | Some prepend_env , None , Some push_var_name -> + ok @@ Environment.add (push_var_name , ty) prepend_env + | None , Some end_env , None -> + ok end_env + | None , Some end_env , Some push_var_name -> ( + if unit_opt + then ok @@ Environment.add (push_var_name , ty) end_env + else ok end_env + ) + in let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in let%bind output_type = Compiler_type.type_ ty in let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in let error_message () = let%bind schema_michelsons = Compiler_type.environment env in ok @@ Format.asprintf - "expression : %a\ncode : %a\nschema type : %a\noutput type : %a" + "expression : %a\ncode : %a\npreenv : %a\npostenv : %a\nschema type : %a\noutput type : %a" PP.expression expr Michelson.pp code + PP.environment env + PP.environment env' PP_helpers.(list_sep Michelson.pp (const ".")) schema_michelsons Michelson.pp output_type in @@ -124,28 +170,27 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m trace (error (thunk "compiling expression") error_message) @@ match expr' with - | E_skip -> return @@ i_skip + | E_skip -> return ~end_env:env ~unit_opt:true @@ seq [] | E_environment_capture c -> let%bind code = Compiler_environment.pack_select env c in return @@ code - | E_environment_load (expr , load_env) -> - let%bind (expr' , _) = translate_expression expr env in + | E_environment_load (expr , load_env) -> ( + let%bind (expr' , _) = translate_expression ~push_var_name:"env_to_load" expr env in let%bind clear = Compiler_environment.select env [] in let%bind unpack = Compiler_environment.unpack load_env in - return ~prepend_env:load_env @@ seq [ + return ~end_env:load_env @@ seq [ expr' ; dip clear ; unpack ; - i_skip ; ] + ) | E_environment_select sub_env -> let%bind code = Compiler_environment.select_env env sub_env in - return ~prepend_env:sub_env @@ seq [ + return ~end_env:sub_env @@ seq [ code ; - i_skip ; ] | E_environment_return expr -> ( - let%bind (expr' , env) = translate_expression expr env in + let%bind (expr' , env) = translate_expression ~push_var_name:"return_clause" expr env in let%bind (code , cleared_env) = Compiler_environment.clear env in return ~end_env:cleared_env @@ seq [ expr' ; @@ -160,8 +205,8 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m match Combinators.Expression.get_type f with | T_function _ -> ( trace (simple_error "Compiling quote application") @@ - let%bind (f , env') = translate_expression ~first f env in - let%bind (arg , _) = translate_expression arg env' in + let%bind (f , env') = translate_expression ~push_var_name:"application_f" f env in + let%bind (arg , _) = translate_expression ~push_var_name:"application_arg" arg env' in return @@ seq [ i_comment "quote application" ; i_comment "get f" ; @@ -173,8 +218,8 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m ) | T_deep_closure (small_env, input_ty , _) -> ( trace (simple_error "Compiling deep closure application") @@ - let%bind (arg' , env') = translate_expression arg env in - let%bind (f' , env'') = translate_expression f env' in + let%bind (arg' , env') = translate_expression ~push_var_name:"closure_arg" arg env in + let%bind (f' , env'') = translate_expression ~push_var_name:"closure_f" f env' in let%bind f_ty = Compiler_type.type_ f.type_value in let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in let error = @@ -207,28 +252,19 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_variable x -> let%bind code = Compiler_environment.get env x in return code - | E_sequence (a , b) -> + | E_sequence (a , b) -> ( let%bind (a' , env_a) = translate_expression a env in - let%bind env_a' = Compiler_environment.pop env_a in - let%bind (b' , env_b) = translate_expression b env_a' in + let%bind (b' , env_b) = translate_expression b env_a in return ~end_env:env_b @@ seq [ a' ; - i_drop ; b' ; ] - (* | E_sequence_drop (a , b) -> - * let%bind (a' , env_a) = translate_expression a env in - * let%bind (b' , env_b) = translate_expression b env_a in - * return ~end_env:env_b @@ seq [ - * a' ; - * i_drop ; - * b' ; - * ] *) + ) | E_constant(str, lst) -> let module L = Logger.Stateful() in let%bind lst' = let aux env expr = - let%bind (code , env') = translate_expression expr env in + let%bind (code , env') = translate_expression ~push_var_name:"constant_argx" expr env in L.log @@ Format.asprintf "\n%a -> %a in %a\n" PP.expression expr Michelson.pp code @@ -269,26 +305,29 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | 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' | E_if_bool (c, a, b) -> ( - let%bind (c' , env') = translate_expression c env in + let%bind (c' , env') = translate_expression ~push_var_name:"bool_condition" c env in let%bind popped = Compiler_environment.pop env' in - let%bind (a' , _) = translate_expression a popped in - let%bind (b' , _) = translate_expression b popped in + let%bind (a' , env_a') = translate_expression ~push_var_name:"if_true" a popped in + let%bind (b' , _env_b') = translate_expression ~push_var_name:"if_false" b popped in let%bind code = ok (seq [ c' ; i_if a' b' ; ]) in - return code + return ~end_env:env_a' code ) | E_if_none (c, n, (ntv , s)) -> ( - let%bind (c' , env') = translate_expression c env in + let%bind (c' , env') = translate_expression ~push_var_name:"if_none_condition" c env in let%bind popped = Compiler_environment.pop env' in - let%bind (n' , _) = translate_expression n popped in + let%bind (n' , _) = translate_expression ~push_var_name:"if_none" n popped in let s_env = Environment.add ntv popped in - let%bind (s' , s_env') = translate_expression s s_env in + let%bind (s' , s_env') = translate_expression ~push_var_name:"if_some" s s_env in let%bind popped' = Compiler_environment.pop s_env' in let%bind restrict_s = Compiler_environment.select_env popped' popped in let%bind code = ok (seq [ @@ -302,11 +341,11 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m return code ) | E_if_left (c, (l_ntv , l), (r_ntv , r)) -> ( - let%bind (c' , _env') = translate_expression c env in + let%bind (c' , _env') = translate_expression ~push_var_name:"if_left_cond" c env in let l_env = Environment.add l_ntv env in - let%bind (l' , _) = translate_expression l l_env in + let%bind (l' , _l_env') = translate_expression ~push_var_name:"if_left" l l_env in let r_env = Environment.add r_ntv env in - let%bind (r' , _) = translate_expression r r_env in + let%bind (r' , _r_env') = translate_expression ~push_var_name:"if_right" r r_env in let%bind restrict_l = Compiler_environment.select_env l_env env in let%bind restrict_r = Compiler_environment.select_env r_env env in let%bind code = ok (seq [ @@ -325,11 +364,11 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m return code ) | E_let_in (v , expr , body) -> ( - let%bind (expr' , expr_env) = translate_expression expr env in + let%bind (expr' , expr_env) = translate_expression ~push_var_name:"let_expr" expr env in let%bind env' = let%bind popped = Compiler_environment.pop expr_env in ok @@ Environment.add v popped in - let%bind (body' , body_env) = translate_expression body env' in + let%bind (body' , body_env) = translate_expression ~push_var_name:"let_body" body env' in let%bind restrict = let%bind popped = Compiler_environment.pop body_env in Compiler_environment.select_env popped env in @@ -341,9 +380,38 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m ]) in return code ) + | E_iterator (name , (v , body) , expr) -> ( + let%bind (expr' , expr_env) = translate_expression ~push_var_name:"iter_expr" expr env in + let%bind popped = Compiler_environment.pop expr_env in + let%bind env' = ok @@ Environment.add v popped in + let%bind (body' , body_env) = translate_expression ~push_var_name:"iter_body" body env' in + match name with + | "ITER" -> ( + let%bind restrict = + Compiler_environment.select_env body_env popped in + let%bind code = ok (seq [ + expr' ; + i_iter (seq [body' ; restrict]) ; + ]) in + return ~end_env:popped code + ) + | "MAP" -> ( + let%bind restrict = + let%bind popped' = Compiler_environment.pop body_env in + Compiler_environment.select_env popped' popped in + let%bind code = ok (seq [ + expr' ; + i_map (seq [body' ; dip restrict]) ; + ]) in + return ~prepend_env:popped code + ) + | s -> ( + let error = error (thunk "bad iterator") (thunk s) in + fail error + ) + ) | E_assignment (name , lrs , expr) -> ( - let%bind (expr' , env') = translate_expression expr env in - (* Format.printf "\nass env':%a\n" PP.environment env' ; *) + let%bind (expr' , env') = translate_expression ~push_var_name:"assignment_expr" expr env in let%bind get_code = Compiler_environment.get env' name in let modify_code = let aux acc step = match step with @@ -365,7 +433,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m in error title content in trace error @@ - return ~prepend_env:env @@ seq [ + return ~end_env:env ~unit_opt:true @@ seq [ i_comment "assign: start # env" ; expr' ; i_comment "assign: compute rhs # rhs : env" ; @@ -377,27 +445,25 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m i_comment "assign: modify code # name+rhs : env" ; set_code ; i_comment "assign: set new # new_env" ; - i_skip ; ] ) - | E_while (expr, block) -> ( - let%bind (expr' , env') = translate_expression expr env in + | E_while (expr , block) -> ( + let%bind (expr' , env') = translate_expression ~push_var_name:"while_expr" expr env in let%bind popped = Compiler_environment.pop env' in let%bind (block' , env'') = translate_expression block popped in let%bind restrict_block = Compiler_environment.select_env env'' popped in - return @@ seq [ + return ~end_env:env ~unit_opt:true @@ seq [ expr' ; prim ~children:[seq [ block' ; restrict_block ; expr']] I_LOOP ; - i_skip ; ] ) and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result = let env = Environment.(add (binder , input) empty) in - let%bind (expr , _) = translate_expression result env in + let%bind (expr , env') = translate_expression result env in let code = seq [ i_comment "function result" ; expr ; @@ -410,10 +476,13 @@ and translate_quote_body ({result ; binder ; input} as f:anon_function) : michel let output_stack_ty = Stack.(output_ty @: nil) in let error_message () = Format.asprintf - "\ncode : %a\ninput : %a\noutput : %a\n" + "\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n" + PP.expression result Michelson.pp code PP.type_ f.input PP.type_ f.output + PP.environment env + PP.environment env' in let%bind _ = Trace.trace_tzresult_lwt ( diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 18ea463cf..5977db461 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -10,12 +10,14 @@ module Contract_types = Meta_michelson.Types module Ty = struct let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) () + let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) () let comparable_type_base : type_base -> ex_comparable_ty result = fun tb -> let open Contract_types in let return x = ok @@ Ex_comparable_ty x in match tb with | Base_unit -> fail (not_comparable "unit") + | Base_void -> fail (not_comparable "void") | Base_bool -> fail (not_comparable "bool") | Base_nat -> return nat_k | Base_tez -> return tez_k @@ -35,6 +37,7 @@ module Ty = struct | T_pair _ -> fail (not_comparable "pair") | T_map _ -> fail (not_comparable "map") | T_list _ -> fail (not_comparable "list") + | T_set _ -> fail (not_comparable "set") | T_option _ -> fail (not_comparable "option") | T_contract _ -> fail (not_comparable "contract") @@ -43,6 +46,7 @@ module Ty = struct let return x = ok @@ Ex_ty x in match b with | Base_unit -> return unit + | Base_void -> fail (not_compilable_type "void") | Base_bool -> return bool | Base_int -> return int | Base_nat -> return nat @@ -82,6 +86,10 @@ module Ty = struct | T_list t -> let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty Contract_types.(list t') + | T_set t -> ( + let%bind (Ex_comparable_ty t') = comparable_type t in + ok @@ Ex_ty Contract_types.(set t') + ) | T_option t -> let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty Contract_types.(option t') @@ -113,6 +121,7 @@ end let base_type : type_base -> O.michelson result = function | Base_unit -> ok @@ O.prim T_unit + | Base_void -> fail (Ty.not_compilable_type "void") | Base_bool -> ok @@ O.prim T_bool | Base_int -> ok @@ O.prim T_int | Base_nat -> ok @@ O.prim T_nat @@ -142,6 +151,9 @@ let rec type_ : type_value -> O.michelson result = | T_list t -> let%bind t' = type_ t in ok @@ O.prim ~children:[t'] O.T_list + | T_set t -> + let%bind t' = type_ t in + ok @@ O.prim ~children:[t'] O.T_set | T_option o -> let%bind o' = type_ o in ok @@ O.prim ~children:[o'] O.T_option diff --git a/src/compiler/uncompiler.ml b/src/compiler/uncompiler.ml index ebf9f4028..8453c6c5a 100644 --- a/src/compiler/uncompiler.ml +++ b/src/compiler/uncompiler.ml @@ -29,6 +29,11 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = trace_option (simple_error "too big to fit an int") @@ Alpha_context.Script_int.to_int n in ok @@ D_nat n + | (Timestamp_t _), n -> + let n = + Z.to_int @@ + Alpha_context.Script_timestamp.to_zint n in + ok @@ D_timestamp n | (Mutez_t _), n -> let%bind n = generic_try (simple_error "too big to fit an int") @@ @@ -63,15 +68,23 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = in ok @@ D_map lst' | (List_t (ty, _)), lst -> + let%bind lst' = + let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in + bind_map_list aux lst + in + ok @@ D_list lst' + | (Set_t (ty, _)), (module S) -> ( + let lst = S.OPS.elements S.boxed in let lst' = let aux acc cur = cur :: acc in let lst = List.fold_left aux lst [] in List.rev lst in let%bind lst'' = - let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in + let aux = fun t -> translate_value (Ex_typed_value (ty_of_comparable_ty ty, t)) in bind_map_list aux lst' in - ok @@ D_list lst'' + ok @@ D_set lst'' + ) | (Operation_t _) , op -> ok @@ D_operation op | ty, v -> diff --git a/src/contracts/amount.mligo b/src/contracts/amount.mligo new file mode 100644 index 000000000..995f165fe --- /dev/null +++ b/src/contracts/amount.mligo @@ -0,0 +1 @@ +let check = if Current.amount > 100tz then 42 else 0 \ No newline at end of file diff --git a/src/contracts/arithmetic.ligo b/src/contracts/arithmetic.ligo index 25b756b04..efaa0e62b 100644 --- a/src/contracts/arithmetic.ligo +++ b/src/contracts/arithmetic.ligo @@ -15,3 +15,6 @@ function div_op (const n : int) : int is function int_op (const n : nat) : int is block { skip } with int(n) + +function neg_op (const n : int) : int is + begin skip end with -n diff --git a/src/contracts/bitwise_arithmetic.ligo b/src/contracts/bitwise_arithmetic.ligo new file mode 100644 index 000000000..0711b5854 --- /dev/null +++ b/src/contracts/bitwise_arithmetic.ligo @@ -0,0 +1,8 @@ +function or_op (const n : nat) : nat is + begin skip end with bitwise_or(n , 4n) + +function and_op (const n : nat) : nat is + begin skip end with bitwise_and(n , 7n) + +function xor_op (const n : nat) : nat is + begin skip end with bitwise_xor(n , 7n) diff --git a/src/contracts/error_syntax.ligo b/src/contracts/error_syntax.ligo new file mode 100644 index 000000000..88deae01f --- /dev/null +++ b/src/contracts/error_syntax.ligo @@ -0,0 +1 @@ +type foo is bar - 42 \ No newline at end of file diff --git a/src/contracts/error_type.ligo b/src/contracts/error_type.ligo new file mode 100644 index 000000000..79e114388 --- /dev/null +++ b/src/contracts/error_type.ligo @@ -0,0 +1 @@ +const foo : nat = 42 + "bar" \ No newline at end of file diff --git a/src/contracts/list.ligo b/src/contracts/list.ligo index 60af05003..99920b92a 100644 --- a/src/contracts/list.ligo +++ b/src/contracts/list.ligo @@ -17,3 +17,17 @@ const bl : foobar = list 120 ; 421 ; end + +function iter_op (const s : list(int)) : int is + var r : int := 0 ; + function aggregate (const i : int) : unit is + begin + r := r + i ; + end with unit + begin + list_iter(s , aggregate) ; + end with r + +function map_op (const s : list(int)) : list(int) is + function increment (const i : int) : int is block { skip } with i + 1 + block { skip } with list_map(s , increment) diff --git a/src/contracts/map.ligo b/src/contracts/map.ligo index bcc2a8005..f0576bf54 100644 --- a/src/contracts/map.ligo +++ b/src/contracts/map.ligo @@ -31,3 +31,14 @@ const bm : foobar = map 120 -> 23 ; 421 -> 23 ; end + +function iter_op (const m : foobar) : int is + var r : int := 0 ; + function aggregate (const i : int ; const j : int) : unit is block { r := r + i + j } with unit ; + block { + map_iter(m , aggregate) ; + } with r ; + +function map_op (const m : foobar) : foobar is + function increment (const i : int ; const j : int) : int is block { skip } with j + 1 ; + block { skip } with map_map(m , increment) ; diff --git a/src/contracts/set_arithmetic.ligo b/src/contracts/set_arithmetic.ligo new file mode 100644 index 000000000..814120c0c --- /dev/null +++ b/src/contracts/set_arithmetic.ligo @@ -0,0 +1,26 @@ +function iter_op (const s : set(int)) : int is + var r : int := 0 ; + function aggregate (const i : int) : unit is + begin + r := r + i ; + end with unit + begin + set_iter(s , aggregate) ; + end with r + +const s_e : set(string) = (set_empty : set(string)) + +const s_fb : set(string) = set [ + "foo" ; + "bar" ; +] + +function add_op (const s : set(string)) : set(string) is + begin skip end with set_add("foobar" , s) + +function remove_op (const s : set(string)) : set(string) is + begin skip end with set_remove("foobar" , s) + +function mem_op (const s : set(string)) : bool is + begin skip end with set_mem("foobar" , s) + diff --git a/src/contracts/string_arithmetic.ligo b/src/contracts/string_arithmetic.ligo new file mode 100644 index 000000000..c8ceacb01 --- /dev/null +++ b/src/contracts/string_arithmetic.ligo @@ -0,0 +1,5 @@ +function concat_op (const s : string) : string is + begin skip end with string_concat(s , "toto") + +function slice_op (const s : string) : string is + begin skip end with string_slice(1n , 2n , s) diff --git a/src/contracts/super-counter.mligo b/src/contracts/super-counter.mligo new file mode 100644 index 000000000..ff3a1f5fb --- /dev/null +++ b/src/contracts/super-counter.mligo @@ -0,0 +1,10 @@ +type action = +| Increment of int +| Decrement of int + +let main (p : action) (s : int) : (operation list * int) = + let storage = + match p with + | Increment n -> s + n + | Decrement n -> s - n in + (([] : operation list) , storage) diff --git a/src/contracts/vote.mligo b/src/contracts/vote.mligo new file mode 100644 index 000000000..136933526 --- /dev/null +++ b/src/contracts/vote.mligo @@ -0,0 +1,55 @@ +type storage = { + title : string ; + candidates : (string , int) map ; + voters : address set ; + beginning_time : timestamp ; + finish_time : timestamp ; +} + +type init_action = { + title : string ; + beginning_time : timestamp ; + finish_time : timestamp ; +} + +type action = + | Vote of string + | Init of init_action + +let init (init_params : init_action) (_ : storage) = + let candidates = Map [ + ("Yes" , 0) ; + ("No" , 0) + ] in + ( + ([] : operation list), + { + title = init_params.title ; + candidates = candidates ; + voters = (Set [] : address set) ; + beginning_time = init_params.beginning_time ; + finish_time = init_params.finish_time ; + } + ) + +let vote (parameter : string) (storage : storage) = + let now = Current.time in + (* let _ = assert (now >= storage.beginning_time && storage.finish_time > now) in *) + let addr = Current.source in + (* let _ = assert (not Set.mem addr storage.voters) in *) + let x = Map.find parameter storage.candidates in + ( + ([] : operation list), + { + title = storage.title ; + candidates = Map.update parameter (Some (x + 1)) storage.candidates ; + voters = Set.add addr storage.voters ; + beginning_time = storage.beginning_time ; + finish_time = storage.finish_time ; + } + ) + +let main (action : action) (storage : storage) = + match action with + | Vote p -> vote p storage + | Init ps -> init ps storage diff --git a/src/dune b/src/dune index 19b622756..3fb9b193b 100644 --- a/src/dune +++ b/src/dune @@ -15,7 +15,7 @@ ) (alias -( name ligo-test) + (name ligo-test) (action (run test/test.exe)) (deps (glob_files contracts/*)) ) @@ -24,3 +24,9 @@ (name runtest) (deps (alias ligo-test)) ) + +(alias + (name manual-test) + (action (run test/manual_test.exe)) + (deps (glob_files contracts/*)) +) \ No newline at end of file diff --git a/src/main/display.ml b/src/main/display.ml new file mode 100644 index 000000000..a68999f28 --- /dev/null +++ b/src/main/display.ml @@ -0,0 +1,42 @@ +open Trace + +let error_pp out (e : error) = + let open JSON_string_utils in + let message = + let opt = e |> member "message" |> string in + match opt with + | Some msg -> ": " ^ msg + | None -> "" in + let error_code = + let error_code = e |> member "error_code" in + match error_code with + | `Null -> "" + | _ -> " (" ^ (J.to_string error_code) ^ ")" in + let title = + let opt = e |> member "title" |> string in + Option.unopt ~default:"" opt in + let data = + let data = e |> member "data" in + match data with + | `Null -> "" + | _ -> " " ^ (J.to_string data) ^ "\n" in + let infos = + let infos = e |> member "infos" in + match infos with + | `List lst -> lst + | `Null -> [] + | x -> [ x ] in + let location = + let opt = e |> member "data" |> member "location" |> string in + let aux prec cur = + match prec with + | None -> cur |> member "data" |> member "location" |> string + | Some s -> Some s + in + match List.fold_left aux opt infos with + | None -> "" + | Some s -> s ^ ". " + in + let print x = Format.fprintf out x in + print "%s%s%s%s%s" location title error_code message data + (* Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos *) diff --git a/src/main/main.ml b/src/main/main.ml index b24f522d4..1c4afcd58 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -16,6 +16,8 @@ module Run = struct include Run_mini_c end +module Display = Display + (* module Parser_multifix = Multifix * module Simplify_multifix = Simplify_multifix *) diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index 17fc40ba2..5c8f12e5d 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -32,8 +32,23 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v error title content in trace error @@ translate_entry entry in - if debug_michelson then Format.printf "Program: %a\n" Michelson.pp compiled.body ; let%bind input_michelson = translate_value input in + if debug_michelson then ( + Format.printf "Program: %a\n" Michelson.pp compiled.body ; + Format.printf "Expression: %a\n" PP.expression entry.result ; + Format.printf "Input: %a\n" PP.value input ; + Format.printf "Input Type: %a\n" PP.type_ entry.input ; + Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; + ) ; let%bind ex_ty_value = run_aux ?options compiled input_michelson in + if debug_michelson then ( + let (Ex_typed_value (ty , v)) = ex_ty_value in + ignore @@ + let%bind michelson_value = + trace_tzresult_lwt (simple_error "debugging run_mini_c") @@ + Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in + Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; + ok () + ) ; let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in ok result diff --git a/src/main/run_simplified.ml b/src/main/run_simplified.ml index 898ba6954..4faf34aaf 100644 --- a/src/main/run_simplified.ml +++ b/src/main/run_simplified.ml @@ -11,14 +11,17 @@ let run_simplityped match last_declaration with | Declaration_constant (_ , (_ , post_env)) -> post_env in - Typer.type_expression env input in + Typer.type_expression env input in let%bind typed_result = Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in let%bind annotated_result = Typer.untype_expression typed_result in ok annotated_result -let evaluate_simplityped (program : Ast_typed.program) (entry : string) +let evaluate_simplityped + ?options + ?(debug_mini_c = false) ?(debug_michelson = false) + (program : Ast_typed.program) (entry : string) : Ast_simplified.expression result = - let%bind typed_result = Run_typed.evaluate_typed entry program in + let%bind typed_result = Run_typed.evaluate_typed ?options ~debug_mini_c ~debug_michelson entry program in let%bind annotated_result = Typer.untype_expression typed_result in ok annotated_result diff --git a/src/main/run_source.ml b/src/main/run_source.ml index e3377472e..a0a18be96 100644 --- a/src/main/run_source.ml +++ b/src/main/run_source.ml @@ -95,24 +95,54 @@ let parsify_expression_ligodity = fun source -> Simplify.Ligodity.simpl_expression raw in ok simplified -let parsify = fun syntax source -> - let%bind parsify = match syntax with - | "pascaligo" -> ok parsify_pascaligo - | "cameligo" -> ok parsify_ligodity - | _ -> simple_fail "unrecognized parser" +type s_syntax = Syntax_name of string +type v_syntax = [`pascaligo | `cameligo ] + +let syntax_to_variant : s_syntax -> string option -> v_syntax result = + fun syntax source_filename -> + let subr s n = + String.sub s (String.length s - n) n in + let endswith s suffix = + let suffixlen = String.length suffix in + ( String.length s >= suffixlen + && String.equal (subr s suffixlen) suffix) in - parsify source + match syntax with + Syntax_name syntax -> + begin + if String.equal syntax "auto" then + begin + match source_filename with + | Some source_filename + when endswith source_filename ".ligo" + -> ok `pascaligo + | Some source_filename + when endswith source_filename ".mligo" + -> ok `cameligo + | _ -> simple_fail "cannot auto-detect syntax, pleas use -s name_of_syntax" + end + else if String.equal syntax "pascaligo" then ok `pascaligo + else if String.equal syntax "cameligo" then ok `cameligo + else simple_fail "unrecognized parser" + end + +let parsify = fun (syntax : v_syntax) source_filename -> + let%bind parsify = match syntax with + | `pascaligo -> ok parsify_pascaligo + | `cameligo -> ok parsify_ligodity + in + parsify source_filename let parsify_expression = fun syntax source -> let%bind parsify = match syntax with - | "pascaligo" -> ok parsify_expression_pascaligo - | "cameligo" -> ok parsify_expression_ligodity - | _ -> simple_fail "unrecognized parser" + | `pascaligo -> ok parsify_expression_pascaligo + | `cameligo -> ok parsify_expression_ligodity in parsify source -let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax -> - let%bind simplified = parsify syntax source in +let compile_contract_file : string -> string -> s_syntax -> string result = fun source_filename entry_point syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify syntax source_filename in let%bind () = assert_entry_point_defined simplified entry_point in let%bind typed = @@ -128,9 +158,10 @@ let compile_contract_file : string -> string -> string -> string result = fun so Format.asprintf "%a" Michelson.pp_stripped michelson in ok str -let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> +let compile_contract_parameter : string -> string -> string -> s_syntax -> string result = fun source_filename entry_point expression syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind (program , parameter_tv) = - let%bind simplified = parsify syntax source in + let%bind simplified = parsify syntax source_filename in let%bind () = assert_entry_point_defined simplified entry_point in let%bind typed = @@ -166,9 +197,10 @@ let compile_contract_parameter : string -> string -> string -> string -> string ok expr -let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax -> +let compile_contract_storage : string -> string -> string -> s_syntax -> string result = fun source_filename entry_point expression syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind (program , storage_tv) = - let%bind simplified = parsify syntax source in + let%bind simplified = parsify syntax source_filename in let%bind () = assert_entry_point_defined simplified entry_point in let%bind typed = @@ -204,8 +236,8 @@ let compile_contract_storage : string -> string -> string -> string -> string re ok expr let type_file ?(debug_simplify = false) ?(debug_typed = false) - syntax (path:string) : Ast_typed.program result = - let%bind simpl = parsify syntax path in + syntax (source_filename:string) : Ast_typed.program result = + let%bind simpl = parsify syntax source_filename in (if debug_simplify then Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl) ) ; @@ -217,12 +249,38 @@ let type_file ?(debug_simplify = false) ?(debug_typed = false) )) ; ok typed - -let run_contract source entry_point storage input syntax = +let run_contract ?amount source_filename entry_point storage input syntax = + let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind typed = - type_file source entry_point in + type_file syntax source_filename in let%bind storage_simpl = - parsify_expression storage syntax in + parsify_expression syntax storage in let%bind input_simpl = - parsify_expression input syntax in - Run_simplified.run_simplityped typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) + parsify_expression syntax input in + let options = + let open Proto_alpha_utils.Memory_proto_alpha in + let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in + (make_options ?amount ()) in + Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) + +let run_function ?amount source_filename entry_point parameter syntax = + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind typed = + type_file syntax source_filename in + let%bind parameter' = + parsify_expression syntax parameter in + let options = + let open Proto_alpha_utils.Memory_proto_alpha in + let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in + (make_options ?amount ()) in + Run_simplified.run_simplityped ~options typed entry_point parameter' + +let evaluate_value ?amount source_filename entry_point syntax = + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind typed = + type_file syntax source_filename in + let options = + let open Proto_alpha_utils.Memory_proto_alpha in + let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in + (make_options ?amount ()) in + Run_simplified.evaluate_simplityped ~options typed entry_point diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index 47a67469d..788a10406 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -13,12 +13,18 @@ let transpile_value let%bind r = Run_mini_c.run_entry f input in ok r -let evaluate_typed (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = +let evaluate_typed + ?(debug_mini_c = false) ?(debug_michelson = false) + ?options (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = trace (simple_error "easy evaluate typed") @@ let%bind result = let%bind mini_c_main = Transpiler.translate_entry program entry in - Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in + (if debug_mini_c then + Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) + ) ; + Run_mini_c.run_entry ?options ~debug_michelson mini_c_main (Mini_c.Combinators.d_unit) + in let%bind typed_result = let%bind typed_main = Ast_typed.get_entry program entry in Transpiler.untranspile result typed_main.type_annotation in diff --git a/src/meta_michelson/contract.ml b/src/meta_michelson/contract.ml index 7e38869c9..a9174a098 100644 --- a/src/meta_michelson/contract.ml +++ b/src/meta_michelson/contract.ml @@ -267,6 +267,7 @@ module Types = struct let key = Key_t None let list a = List_t (a, None) + let set a = Set_t (a, None) let assert_list = function | List_t (a, _) -> a | _ -> assert false diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 51867e490..3d0e3f065 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -10,6 +10,7 @@ let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R let type_base ppf : type_base -> _ = function | Base_unit -> fprintf ppf "unit" + | Base_void -> fprintf ppf "void" | Base_bool -> fprintf ppf "bool" | Base_int -> fprintf ppf "int" | Base_nat -> fprintf ppf "nat" @@ -27,6 +28,7 @@ let rec type_ ppf : type_value -> _ = function | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v | T_list(t) -> fprintf ppf "list(%a)" type_ t + | T_set(t) -> fprintf ppf "set(%a)" type_ t | T_option(o) -> fprintf ppf "option(%a)" type_ o | T_contract(t) -> fprintf ppf "contract(%a)" type_ t | T_deep_closure(c, arg, ret) -> @@ -45,8 +47,9 @@ let rec value ppf : value -> unit = function | D_operation _ -> fprintf ppf "operation[...bytes]" | D_int n -> fprintf ppf "%d" n | D_nat n -> fprintf ppf "+%d" n + | D_timestamp n -> fprintf ppf "+%d" n | D_tez n -> fprintf ppf "%dtz" n - | D_unit -> fprintf ppf " " + | D_unit -> fprintf ppf "unit" | D_string s -> fprintf ppf "\"%s\"" s | D_bytes _ -> fprintf ppf "[bytes]" | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b @@ -57,6 +60,7 @@ let rec value ppf : value -> unit = function | D_some s -> fprintf ppf "Some (%a)" value s | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst + | D_set lst -> fprintf ppf "Set[%a]" (list_sep_d value) lst and value_assoc ppf : (value * value) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" value a value b @@ -65,23 +69,25 @@ and expression' ppf (e:expression') = match e with | E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s | E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env | E_environment_select env -> fprintf ppf "select %a" environment env - | E_environment_return expr -> fprintf ppf "return %a" expression expr + | E_environment_return expr -> fprintf ppf "return (%a)" expression expr | E_skip -> fprintf ppf "skip" - | E_variable v -> fprintf ppf "%s" v + | E_variable v -> fprintf ppf "V(%s)" v | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst - | E_literal v -> fprintf ppf "%a" value v + | E_literal v -> fprintf ppf "L(%a)" value v | E_make_empty_map _ -> fprintf ppf "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 : %s -> %a" expression c expression n name expression s | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r - | E_sequence (a , b) -> fprintf ppf "%a ; %a" expression a expression b - (* | E_sequence_drop (a , b) -> fprintf ppf "%a ;- %a" expression a expression b *) + | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b | E_let_in ((name , _) , expr , body) -> fprintf ppf "let %s = %a in ( %a )" name expression expr expression body + | E_iterator (s , ((name , _) , body) , expr) -> + fprintf ppf "for_%s %s of %a do ( %a )" s name expression expr expression body | E_assignment (r , path , e) -> fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e | E_while (e , b) -> diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index 670d63e5f..3aa4d5726 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -37,6 +37,10 @@ let get_nat (v:value) = match v with | D_nat n -> ok n | _ -> simple_fail "not a nat" +let get_timestamp (v:value) = match v with + | D_timestamp n -> ok n + | _ -> simple_fail "not a timestamp" + let get_string (v:value) = match v with | D_string s -> ok s | _ -> simple_fail "not a string" @@ -62,6 +66,10 @@ let get_list (v:value) = match v with | D_list lst -> ok lst | _ -> simple_fail "not a list" +let get_set (v:value) = match v with + | D_set lst -> ok lst + | _ -> simple_fail "not a set" + let get_t_option (v:type_value) = match v with | T_option t -> ok t | _ -> simple_fail "not an option" @@ -82,6 +90,10 @@ let get_t_list (t:type_value) = match t with | T_list t -> ok t | _ -> simple_fail "not a type list" +let get_t_set (t:type_value) = match t with + | T_set t -> ok t + | _ -> simple_fail "not a type set" + let get_left (v:value) = match v with | D_left b -> ok b | _ -> simple_fail "not a left" diff --git a/src/mini_c/environment.ml b/src/mini_c/environment.ml index 8c1bc796c..1d7463c48 100644 --- a/src/mini_c/environment.ml +++ b/src/mini_c/environment.ml @@ -32,14 +32,18 @@ module Environment (* : ENVIRONMENT *) = struct let get_names : t -> string list = List.map fst let remove : int -> t -> t = List.remove - let select : string list -> t -> t = fun lst env -> + let select ?(rev = false) ?(keep = true) : string list -> t -> t = fun lst env -> let e_lst = let e_lst = to_list env in let aux selector (s , _) = match List.mem s selector with - | true -> List.remove_element s selector , true - | false -> selector , false in - let e_lst' = List.fold_map_right aux lst e_lst in + | true -> List.remove_element s selector , keep + | false -> selector , not keep in + let e_lst' = + if rev = keep + then List.fold_map aux lst e_lst + else List.fold_map_right aux lst e_lst + in let e_lst'' = List.combine e_lst e_lst' in e_lst'' in of_list diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 6e5bb4906..3e9a69819 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -1,7 +1,7 @@ type type_name = string type type_base = - | Base_unit + | Base_unit | Base_void | Base_bool | Base_int | Base_nat | Base_tez | Base_timestamp @@ -16,6 +16,7 @@ type type_value = | T_base of type_base | T_map of (type_value * type_value) | T_list of type_value + | T_set of type_value | T_contract of type_value | T_option of type_value @@ -35,6 +36,7 @@ type value = | D_unit | D_bool of bool | D_nat of int + | D_timestamp of int | D_tez of int | D_int of int | D_string of string @@ -46,6 +48,7 @@ type value = | D_none | D_map of (value * value) list | D_list of value list + | D_set of value list (* | `Macro of anon_macro ... The future. *) | D_function of anon_function | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation @@ -64,7 +67,9 @@ and expression' = | E_variable of var_name | E_make_empty_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 (string * ((var_name * type_value) * expression) * expression) | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) diff --git a/src/operators/helpers.ml b/src/operators/helpers.ml index 7cdc617f4..8fd18a16f 100644 --- a/src/operators/helpers.ml +++ b/src/operators/helpers.ml @@ -70,6 +70,33 @@ module Typer = struct | _ -> fail @@ wrong_param_number s 3 lst let typer_3 name f : typer = (name , typer'_3 name f) + let typer'_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ -> + match lst with + | [ a ; b ; c ; d ] -> ( + let%bind tv' = f a b c d in + ok (s , tv') + ) + | _ -> fail @@ wrong_param_number s 4 lst + let typer_4 name f : typer = (name , typer'_4 name f) + + let typer'_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ -> + match lst with + | [ a ; b ; c ; d ; e ] -> ( + let%bind tv' = f a b c d e in + ok (s , tv') + ) + | _ -> fail @@ wrong_param_number s 5 lst + let typer_5 name f : typer = (name , typer'_5 name f) + + let typer'_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ -> + match lst with + | [ a ; b ; c ; d ; e ; f_ ] -> ( + let%bind tv' = f a b c d e f_ in + ok (s , tv') + ) + | _ -> fail @@ wrong_param_number s 6 lst + let typer_6 name f : typer = (name , typer'_6 name f) + let constant name cst = typer_0 name (fun _ -> ok cst) open Combinators @@ -77,6 +104,8 @@ module Typer = struct let eq_1 a cst = type_value_eq (a , cst) let eq_2 (a , b) cst = type_value_eq (a , cst) && type_value_eq (b , cst) + let assert_eq_1 a b = Assert.assert_true (eq_1 a b) + let comparator : string -> typer = fun s -> typer_2 s @@ fun a b -> let%bind () = trace_strong (error_uncomparable_types a b) @@ @@ -88,6 +117,7 @@ module Typer = struct t_string () ; t_bytes () ; t_address () ; + t_timestamp () ; ] in ok @@ t_bool () @@ -113,8 +143,14 @@ module Compiler = struct | Unary of michelson | Binary of michelson | Ternary of michelson + | Tetrary of michelson + | Pentary of michelson + | Hexary of michelson let simple_constant c = Constant c let simple_unary c = Unary c let simple_binary c = Binary c let simple_ternary c = Ternary c + let simple_tetrary c = Tetrary c + let simple_pentary c = Pentary c + let simple_hexary c = Hexary c end diff --git a/src/operators/operators.ml b/src/operators/operators.ml index d8c3d134f..67c0cdb28 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -42,6 +42,9 @@ module Simplify = struct ("bool" , "bool") ; ("operation" , "operation") ; ("address" , "address") ; + ("key" , "key") ; + ("key_hash" , "key_hash") ; + ("signature" , "signature") ; ("timestamp" , "timestamp") ; ("contract" , "contract") ; ("list" , "list") ; @@ -66,6 +69,20 @@ module Simplify = struct ("source" , "SOURCE") ; ("sender" , "SENDER") ; ("failwith" , "FAILWITH") ; + ("bitwise_or" , "OR") ; + ("bitwise_and" , "AND") ; + ("bitwise_xor" , "XOR") ; + ("string_concat" , "CONCAT") ; + ("string_slice" , "SLICE") ; + ("set_empty" , "SET_EMPTY") ; + ("set_mem" , "SET_MEM") ; + ("set_add" , "SET_ADD") ; + ("set_remove" , "SET_REMOVE") ; + ("set_iter" , "SET_ITER") ; + ("list_iter" , "LIST_ITER") ; + ("list_map" , "LIST_MAP") ; + ("map_iter" , "MAP_ITER") ; + ("map_map" , "MAP_MAP") ; ] let type_constants = type_constants @@ -76,7 +93,7 @@ module Simplify = struct ("Bytes.pack" , "PACK") ; ("Crypto.hash" , "HASH") ; ("Operation.transaction" , "CALL") ; - ("Operation.get_contract" , "GET_CONTRACT") ; + ("Operation.get_contract" , "CONTRACT") ; ("sender" , "SENDER") ; ("unit" , "UNIT") ; ("source" , "SOURCE") ; @@ -87,6 +104,8 @@ module Simplify = struct module Ligodity = struct let constants = [ + ("assert" , "ASSERT") ; + ("Current.balance", "BALANCE") ; ("balance", "BALANCE") ; ("Current.time", "NOW") ; @@ -97,6 +116,8 @@ module Simplify = struct ("gas", "STEPS_TO_QUOTA") ; ("Current.sender" , "SENDER") ; ("sender", "SENDER") ; + ("Current.source" , "SOURCE") ; + ("source", "SOURCE") ; ("Current.failwith", "FAILWITH") ; ("failwith" , "FAILWITH") ; @@ -115,6 +136,17 @@ module Simplify = struct ("Bytes.slice", "SLICE") ; ("Bytes.sub", "SLICE") ; + ("Set.mem" , "SET_MEM") ; + ("Set.empty" , "SET_EMPTY") ; + ("Set.add" , "SET_ADD") ; + ("Set.remove" , "SET_REMOVE") ; + + ("Map.find_opt" , "MAP_FIND_OPT") ; + ("Map.find" , "MAP_FIND") ; + ("Map.update" , "MAP_UPDATE") ; + ("Map.add" , "MAP_ADD") ; + ("Map.remove" , "MAP_REMOVE") ; + ("String.length", "SIZE") ; ("String.size", "SIZE") ; ("String.slice", "SLICE") ; @@ -126,7 +158,7 @@ module Simplify = struct ("List.iter", "ITER") ; ("Operation.transaction" , "CALL") ; - ("Operation.get_contract" , "GET_CONTRACT") ; + ("Operation.get_contract" , "CONTRACT") ; ("int" , "INT") ; ("abs" , "ABS") ; ("unit" , "UNIT") ; @@ -171,6 +203,11 @@ module Typer = struct | None -> simple_fail "untyped NONE" | Some t -> ok t + let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt -> + match tv_opt with + | None -> simple_fail "untyped SET_EMPTY" + | Some t -> ok t + let sub = typer_2 "SUB" @@ fun a b -> if (eq_2 (a , b) (t_int ())) then ok @@ t_int () else @@ -178,6 +215,8 @@ module Typer = struct then ok @@ t_int () else if (eq_2 (a , b) (t_timestamp ())) then ok @@ t_int () else + if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) + then ok @@ t_timestamp () else if (eq_2 (a , b) (t_tez ())) then ok @@ t_tez () else fail (simple_error "Typing substraction, bad parameters.") @@ -195,57 +234,95 @@ module Typer = struct let%bind () = assert_type_value_eq (dst, v) in ok m - let map_update : typer = typer_3 "MAP_UPDATE_TODO" @@ fun k v m -> + let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m -> let%bind (src, dst) = get_t_map m in let%bind () = assert_type_value_eq (src, k) in let%bind v' = get_t_option v in let%bind () = assert_type_value_eq (dst, v') in ok m - let map_mem : typer = typer_2 "MAP_MEM_TODO" @@ fun k m -> + let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m -> let%bind (src, _dst) = get_t_map m in let%bind () = assert_type_value_eq (src, k) in ok @@ t_bool () - let map_find : typer = typer_2 "MAP_FIND_TODO" @@ fun k m -> + let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> + let%bind (src, dst) = get_t_map m in + let%bind () = assert_type_value_eq (src, k) in + ok @@ dst + + let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m -> let%bind (src, dst) = get_t_map m in let%bind () = assert_type_value_eq (src, k) in ok @@ t_option dst () - let map_fold : typer = typer_3 "MAP_FOLD_TODO" @@ fun f m acc -> - let%bind (src, dst) = get_t_map m in - let expected_f_type = t_function (t_tuple [(t_tuple [src ; dst] ()) ; acc] ()) acc () in - let%bind () = assert_type_value_eq (f, expected_f_type) in - ok @@ acc - - let map_map : typer = typer_2 "MAP_MAP_TODO" @@ fun f m -> + let map_iter : typer = typer_2 "MAP_ITER" @@ fun m f -> let%bind (k, v) = get_t_map m in - let%bind (input_type, result_type) = get_t_function f in - let%bind () = assert_type_value_eq (input_type, t_tuple [k ; v] ()) in - ok @@ t_map k result_type () - - let map_map_fold : typer = typer_3 "MAP_MAP_TODO" @@ fun f m acc -> - let%bind (k, v) = get_t_map m in - let%bind (input_type, result_type) = get_t_function f in - let%bind () = assert_type_value_eq (input_type, t_tuple [t_tuple [k ; v] () ; acc] ()) in - let%bind ttuple = get_t_tuple result_type in - match ttuple with - | [result_acc ; result_dst ] -> - ok @@ t_tuple [ t_map k result_dst () ; result_acc ] () - (* TODO: error message *) - | _ -> fail @@ simple_error "function passed to map should take (k * v) * acc as an argument" - - let map_iter : typer = typer_2 "MAP_MAP_TODO" @@ fun f m -> - let%bind (k, v) = get_t_map m in - let%bind () = assert_type_value_eq (f, t_function (t_tuple [k ; v] ()) (t_unit ()) ()) in + let%bind (arg , res) = get_t_function f in + let%bind () = assert_eq_1 arg (t_pair k v ()) in + let%bind () = assert_eq_1 res (t_unit ()) in ok @@ t_unit () + let map_map : typer = typer_2 "MAP_MAP" @@ fun m f -> + let%bind (k, v) = get_t_map m in + let%bind (arg , res) = get_t_function f in + let%bind () = assert_eq_1 arg (t_pair k v ()) in + ok @@ t_map k res () + + let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> + let%bind (k, v) = get_t_map m in + let%bind (arg_1 , res) = get_t_function f in + let%bind (arg_2 , res') = get_t_function res in + let%bind (arg_3 , res'') = get_t_function res' in + let%bind () = assert_eq_1 arg_1 k in + let%bind () = assert_eq_1 arg_2 v in + let%bind () = assert_eq_1 arg_3 res'' in + ok @@ res' + + let big_map_remove : typer = typer_2 "BIG_MAP_REMOVE" @@ fun k m -> + let%bind (src , _) = get_t_big_map m in + let%bind () = assert_type_value_eq (src , k) in + ok m + + let big_map_add : typer = typer_3 "BIG_MAP_ADD" @@ fun k v m -> + let%bind (src, dst) = get_t_big_map m in + let%bind () = assert_type_value_eq (src, k) in + let%bind () = assert_type_value_eq (dst, v) in + ok m + + let big_map_update : typer = typer_3 "BIG_MAP_UPDATE" @@ fun k v m -> + let%bind (src, dst) = get_t_big_map m in + let%bind () = assert_type_value_eq (src, k) in + let%bind v' = get_t_option v in + let%bind () = assert_type_value_eq (dst, v') in + ok m + + let big_map_mem : typer = typer_2 "BIG_MAP_MEM" @@ fun k m -> + let%bind (src, _dst) = get_t_big_map m in + let%bind () = assert_type_value_eq (src, k) in + ok @@ t_bool () + + let big_map_find : typer = typer_2 "BIG_MAP_FIND" @@ fun k m -> + let%bind (src, dst) = get_t_big_map m in + let%bind () = assert_type_value_eq (src, k) in + ok @@ dst + + let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ - (is_t_map t || is_t_list t) in + (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t || is_t_big_map t) in ok @@ t_nat () + let slice = typer_3 "SLICE" @@ fun i j s -> + let%bind () = assert_eq_1 i (t_nat ()) in + let%bind () = assert_eq_1 j (t_nat ()) in + if eq_1 s (t_string ()) + then ok @@ t_string () + else if eq_1 s (t_bytes ()) + then ok @@ t_bytes () + else simple_fail "bad slice" + let failwith_ = typer_1 "FAILWITH" @@ fun t -> let%bind () = Assert.assert_true @@ @@ -269,10 +346,28 @@ module Typer = struct trace_option (simple_error "untyped UNPACK") @@ output_opt - let crypto_hash = typer_1 "HASH" @@ fun t -> + let hash256 = typer_1 "SHA256" @@ fun t -> let%bind () = assert_t_bytes t in ok @@ t_bytes () + let hash512 = typer_1 "SHA512" @@ fun t -> + let%bind () = assert_t_bytes t in + ok @@ t_bytes () + + let blake2b = typer_1 "BLAKE2b" @@ fun t -> + let%bind () = assert_t_bytes t in + ok @@ t_bytes () + + let hash_key = typer_1 "HASH_KEY" @@ fun t -> + let%bind () = assert_t_key t in + ok @@ t_key_hash () + + let check_signature = typer_3 "CHECK_SIGNATURE" @@ fun k s b -> + let%bind () = assert_t_key k in + let%bind () = assert_t_signature s in + let%bind () = assert_t_bytes b in + ok @@ t_bool () + let sender = constant "SENDER" @@ t_address () let source = constant "SOURCE" @@ t_address () @@ -281,6 +376,10 @@ module Typer = struct let amount = constant "AMOUNT" @@ t_tez () + let balance = constant "BALANCE" @@ t_tez () + + let address = constant "ADDRESS" @@ t_address () + let now = constant "NOW" @@ t_timestamp () let transaction = typer_3 "CALL" @@ fun param amount contract -> @@ -289,6 +388,19 @@ module Typer = struct let%bind () = assert_type_value_eq (param , contract_param) in ok @@ t_operation () + let originate = typer_6 "ORIGINATE" @@ fun manager delegate_opt spendable delegatable init_balance code -> + let%bind () = assert_eq_1 manager (t_key_hash ()) in + let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in + let%bind () = assert_eq_1 spendable (t_bool ()) in + let%bind () = assert_eq_1 delegatable (t_bool ()) in + let%bind () = assert_t_tez init_balance in + let%bind (arg , res) = get_t_function code in + let%bind (_param , storage) = get_t_pair arg in + let%bind (storage' , op_lst) = get_t_pair res in + let%bind () = assert_eq_1 storage storage' in + let%bind () = assert_eq_1 op_lst (t_list (t_operation ()) ()) in + ok @@ (t_pair (t_operation ()) (t_address ()) ()) + let get_contract = typer_1_opt "CONTRACT" @@ fun _ tv_opt -> let%bind tv = trace_option (simple_error "get_contract needs a type annotation") tv_opt in @@ -297,10 +409,23 @@ module Typer = struct get_t_contract tv in ok @@ t_contract tv' () + let set_delegate = typer_1 "SET_DELEGATE" @@ fun delegate_opt -> + let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in + ok @@ t_operation () + let abs = typer_1 "ABS" @@ fun t -> let%bind () = assert_t_int t in ok @@ t_nat () + let neg = typer_1 "NEG" @@ fun t -> + let%bind () = Assert.assert_true (eq_1 t (t_nat ()) || eq_1 t (t_int ())) in + ok @@ t_int () + + let assertion = typer_1 "ASSERT" @@ fun a -> + if eq_1 a (t_bool ()) + then ok @@ t_unit () + else simple_fail "Asserting a non-bool" + let times = typer_2 "TIMES" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else @@ -333,8 +458,101 @@ module Typer = struct then ok @@ t_tez () else if (eq_1 a (t_nat ()) && eq_1 b (t_int ())) || (eq_1 b (t_nat ()) && eq_1 a (t_int ())) then ok @@ t_int () else + if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) || (eq_1 b (t_timestamp ()) && eq_1 a (t_int ())) + then ok @@ t_timestamp () else simple_fail "Adding with wrong types. Expected nat, int or tez." + let set_mem = typer_2 "SET_MEM" @@ fun elt set -> + let%bind key = get_t_set set in + if eq_1 elt key + then ok @@ t_bool () + else simple_fail "Set_mem: elt and set don't match" + + let set_add = typer_2 "SET_ADD" @@ fun elt set -> + let%bind key = get_t_set set in + if eq_1 elt key + then ok set + else simple_fail "Set_add: elt and set don't match" + + let set_remove = typer_2 "SET_REMOVE" @@ fun elt set -> + let%bind key = get_t_set set in + if eq_1 elt key + then ok set + else simple_fail "Set_remove: elt and set don't match" + + let set_iter = typer_2 "SET_ITER" @@ fun set body -> + let%bind (arg , res) = get_t_function body in + let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in + let%bind key = get_t_set set in + if eq_1 key arg + then ok (t_unit ()) + else simple_fail "bad set iter" + + let list_iter = typer_2 "LIST_ITER" @@ fun lst body -> + let%bind (arg , res) = get_t_function body in + let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in + let%bind key = get_t_list lst in + if eq_1 key arg + then ok (t_unit ()) + else simple_fail "bad list iter" + + let list_map = typer_2 "LIST_MAP" @@ fun lst body -> + let%bind (arg , res) = get_t_function body in + let%bind key = get_t_list lst in + if eq_1 key arg + then ok (t_list res ()) + else simple_fail "bad list iter" + + let not_ = typer_1 "NOT" @@ fun elt -> + if eq_1 elt (t_bool ()) + then ok @@ t_bool () + else if eq_1 elt (t_nat ()) || eq_1 elt (t_int ()) + then ok @@ t_int () + else simple_fail "bad parameter to not" + + let or_ = typer_2 "OR" @@ fun a b -> + if eq_2 (a , b) (t_bool ()) + then ok @@ t_bool () + else if eq_2 (a , b) (t_nat ()) + then ok @@ t_nat () + else simple_fail "bad or" + + let xor = typer_2 "XOR" @@ fun a b -> + if eq_2 (a , b) (t_bool ()) + then ok @@ t_bool () + else if eq_2 (a , b) (t_nat ()) + then ok @@ t_nat () + else simple_fail "bad xor" + + let and_ = typer_2 "AND" @@ fun a b -> + if eq_2 (a , b) (t_bool ()) + then ok @@ t_bool () + else if eq_2 (a , b) (t_nat ()) || (eq_1 b (t_nat ()) && eq_1 a (t_int ())) + then ok @@ t_nat () + else simple_fail "bad end" + + let lsl_ = typer_2 "LSL" @@ fun a b -> + if eq_2 (a , b) (t_nat ()) + then ok @@ t_nat () + else simple_fail "bad lsl" + + let lsr_ = typer_2 "LSR" @@ fun a b -> + if eq_2 (a , b) (t_nat ()) + then ok @@ t_nat () + else simple_fail "bad lsr" + + let concat = typer_2 "CONCAT" @@ fun a b -> + if eq_2 (a , b) (t_string ()) + then ok @@ t_string () + else if eq_2 (a , b) (t_bytes ()) + then ok @@ t_bytes () + else simple_fail "bad concat" + + let cons = typer_2 "CONS" @@ fun hd tl -> + let%bind elt = get_t_list tl in + let%bind () = assert_eq_1 hd elt in + ok tl + let constant_typers = Map.String.of_list [ add ; times ; @@ -343,39 +561,57 @@ module Typer = struct sub ; none ; some ; + concat ; + slice ; comparator "EQ" ; comparator "NEQ" ; comparator "LT" ; comparator "GT" ; comparator "LE" ; comparator "GE" ; - boolean_operator_2 "OR" ; - boolean_operator_2 "AND" ; + or_ ; + and_ ; + xor ; + not_ ; map_remove ; map_add ; map_update ; map_mem ; map_find ; - map_map_fold ; map_map ; map_fold ; map_iter ; - (* map_size ; (* use size *) *) + map_map ; + set_empty ; + set_mem ; + set_add ; + set_remove ; + set_iter ; + list_iter ; + list_map ; int ; size ; failwith_ ; get_force ; bytes_pack ; bytes_unpack ; - crypto_hash ; + hash256 ; + hash512 ; + blake2b ; + hash_key ; + check_signature ; sender ; source ; unit ; amount ; transaction ; get_contract ; + neg ; abs ; now ; + slice ; + address ; + assertion ; ] end @@ -407,6 +643,8 @@ module Compiler = struct ("NEG" , simple_unary @@ prim I_NEG) ; ("OR" , simple_binary @@ prim I_OR) ; ("AND" , simple_binary @@ prim I_AND) ; + ("XOR" , simple_binary @@ prim I_XOR) ; + ("NOT" , simple_unary @@ prim I_NOT) ; ("PAIR" , simple_binary @@ prim I_PAIR) ; ("CAR" , simple_unary @@ prim I_CAR) ; ("CDR" , simple_unary @@ prim I_CDR) ; @@ -419,21 +657,37 @@ module Compiler = struct ("UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SOME" , simple_unary @@ prim I_SOME) ; ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; + ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ; ("MAP_GET" , simple_binary @@ prim I_GET) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; - ("ASSERT" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; + ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; + ("ASSERT" , simple_unary @@ i_if (seq [i_push_unit ; i_failwith]) (seq [i_push_unit])) ; ("INT" , simple_unary @@ prim I_INT) ; ("ABS" , simple_unary @@ prim I_ABS) ; ("CONS" , simple_binary @@ prim I_CONS) ; ("UNIT" , simple_constant @@ prim I_UNIT) ; ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ; + ("ADDRESS" , simple_constant @@ prim I_ADDRESS) ; ("NOW" , simple_constant @@ prim I_NOW) ; ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ; ("SOURCE" , simple_constant @@ prim I_SOURCE) ; ("SENDER" , simple_constant @@ prim I_SENDER) ; - ( "MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ; - ( "MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; + ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; + ("SET_MEM" , simple_binary @@ prim I_MEM) ; + ("SET_ADD" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) ; + ("SET_REMOVE" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) ; + ("SLICE" , simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")]) ; + ("SHA256" , simple_unary @@ prim I_SHA256) ; + ("SHA512" , simple_unary @@ prim I_SHA512) ; + ("BLAKE2B" , simple_unary @@ prim I_BLAKE2B) ; + ("CHECK_SIGNATURE" , simple_ternary @@ prim I_CHECK_SIGNATURE) ; + ("HASH_KEY" , simple_unary @@ prim I_HASH_KEY) ; + ("PACK" , simple_unary @@ prim I_PACK) ; + ("CONCAT" , simple_binary @@ prim I_CONCAT) ; ] + (* Some complex predicates will need to be added in compiler/compiler_program *) + end diff --git a/src/parser/ligodity.ml b/src/parser/ligodity.ml index fba239b59..b56d63ea2 100644 --- a/src/parser/ligodity.ml +++ b/src/parser/ligodity.ml @@ -34,6 +34,19 @@ let parse_file (source: string) : AST.t result = in simple_error str ) + | Lexer.Error err -> ( + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Lexer error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (err.value) + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str + ) | exn -> let start = Lexing.lexeme_start_p lexbuf in let end_ = Lexing.lexeme_end_p lexbuf in diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index cd3a4472d..34866fd91 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -147,6 +147,22 @@ module Errors = struct ] in error ~data title message + let bad_set_definition = + let title () = "bad set definition" in + let message () = "a set definition is a list" in + info title message + + let bad_list_definition = + let title () = "bad list definition" in + let message () = "a list definition is a list" in + info title message + + let bad_map_definition = + let title () = "bad map definition" in + let message () = "a map definition is a list of pairs" in + info title message + + let corner_case ~loc message = let title () = "corner case" in let content () = "We don't have a good error message for this case. \ @@ -158,6 +174,7 @@ module Errors = struct ("message" , fun () -> message) ; ] in error ~data title content + end open Errors @@ -170,6 +187,7 @@ let rec pattern_to_var : Raw.pattern -> _ = fun p -> match p with | Raw.PPar p -> pattern_to_var p.value.inside | Raw.PVar v -> ok v + | Raw.PWild r -> ok @@ ({ region = r ; value = "_" } : Raw.variable) | _ -> fail @@ wrong_pattern "var" p let rec pattern_to_typed_var : Raw.pattern -> _ = fun p -> @@ -181,6 +199,7 @@ let rec pattern_to_typed_var : Raw.pattern -> _ = fun p -> ok (v , Some tp.type_expr) ) | Raw.PVar v -> ok (v , None) + | Raw.PWild r -> ok (({ region = r ; value = "_" } : Raw.variable) , None) | _ -> fail @@ wrong_pattern "typed variable" p let rec expr_to_typed_expr : Raw.expr -> _ = fun e -> @@ -358,10 +377,37 @@ let rec simpl_expression : let (c_name , _c_loc) = r_split c_name in let args = match args with - None -> [] + | None -> [] | Some arg -> [arg] in let%bind arg = simpl_tuple_expression @@ args in - return @@ e_constructor ~loc c_name arg + match c_name with + | "Set" -> ( + let%bind args' = + trace bad_set_definition @@ + extract_list arg in + return @@ e_set ~loc args' + ) + | "List" -> ( + let%bind args' = + trace bad_list_definition @@ + extract_list arg in + return @@ e_list ~loc args' + ) + | "Map" -> ( + let%bind args' = + trace bad_map_definition @@ + extract_list arg in + let%bind pairs = + trace bad_map_definition @@ + bind_map_list extract_pair args' in + return @@ e_map ~loc pairs + ) + | "Some" -> ( + return @@ e_some ~loc arg + ) + | _ -> ( + return @@ e_constructor ~loc c_name arg + ) ) | EArith (Add c) -> simpl_binop "ADD" c diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index 01e83b325..c7d803f1f 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -135,7 +135,7 @@ module Errors = struct let unsupported_for_loops region = let title () = "bounded iterators" in let message () = - Format.asprintf "for loops are not supported yet" in + Format.asprintf "only simple for loops are supported yet" in let data = [ ("loop_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ region) @@ -468,12 +468,11 @@ let rec simpl_expression (t:Raw.expr) : expr result = return @@ e_literal ~loc (Literal_nat n) ) | EArith (Mtz n) -> ( - let (n , loc) = r_split n in - let n = Z.to_int @@ snd @@ n in - return @@ e_literal ~loc (Literal_tez n) - ) - | EArith _ as e -> - fail @@ unsupported_arith_op e + let (n , loc) = r_split n in + let n = Z.to_int @@ snd @@ n in + return @@ e_literal ~loc (Literal_tez n) + ) + | EArith (Neg e) -> simpl_unop "NEG" e | EString (String s) -> let (s , loc) = r_split s in let s' = @@ -485,7 +484,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = fail @@ unsupported_string_catenation e | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l - | ESet _ -> fail @@ unsupported_set_expr t + | ESet s -> simpl_set_expression s | ECase c -> ( let (c , loc) = r_split c in let%bind e = simpl_expression c.expr in @@ -572,6 +571,21 @@ and simpl_list_expression (t:Raw.list_expr) : expression result = return @@ e_list ~loc [] ) +and simpl_set_expression (t:Raw.set_expr) : expression result = + match t with + | SetMem x -> ( + let (x' , loc) = r_split x in + let%bind set' = simpl_expression x'.set in + let%bind element' = simpl_expression x'.element in + ok @@ e_constant ~loc "SET_MEM" [ element' ; set' ] + ) + | SetInj x -> ( + let (x' , loc) = r_split x in + let elements = pseq_to_list x'.elements in + let%bind elements' = bind_map_list simpl_expression elements in + ok @@ e_set ~loc elements' + ) + and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = let return x = ok x in let (t , loc) = r_split t in @@ -730,8 +744,19 @@ and simpl_statement : Raw.statement -> (_ -> expression result) result = and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = fun t -> match t with - | ProcCall call -> - fail @@ unsupported_proc_calls call + | ProcCall x -> ( + let ((name, args) , loc) = r_split x in + let (f , f_loc) = r_split name in + let (args , args_loc) = r_split args in + let args' = npseq_to_list args.inside in + match List.assoc_opt f constants with + | None -> + let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + return @@ e_application ~loc (e_variable ~loc:f_loc f) arg + | Some s -> + let%bind lst = bind_map_list simpl_expression args' in + return @@ e_constant ~loc s lst + ) | Fail e -> ( let%bind expr = simpl_expression e.value.fail_expr in return @@ e_failwith expr @@ -746,7 +771,13 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let%bind body = simpl_block l.block.value in let%bind body = body None in return @@ e_loop cond body - | Loop (For (ForInt {region; _} | ForCollect {region; _})) -> + (* | Loop (For (ForCollect x)) -> ( + * let (x' , loc) = r_split x in + * let%bind expr = simpl_expression x'.expr in + * let%bind body = simpl_block x'.block.value in + * ok _ + * ) *) + | Loop (For (ForInt {region; _} | ForCollect {region ; _})) -> fail @@ unsupported_for_loops region | Cond c -> ( let (c , loc) = r_split c in diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index d54239a64..2ee1485bc 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -4,7 +4,7 @@ open Test_helpers let compile_contract_basic () : unit result = let%bind _ = - compile_contract_file "./contracts/dispatch-counter.ligo" "main" "pascaligo" + compile_contract_file "./contracts/dispatch-counter.ligo" "main" (Syntax_name "pascaligo") in ok () diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 2f16212d4..0db0e53f8 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -4,7 +4,7 @@ open Trace open Ligo.Run open Test_helpers -let type_file = type_file "pascaligo" +let type_file = type_file `pascaligo let get_program = let s = ref None in @@ -217,7 +217,7 @@ let sell () = let expected_storage = let cards = List.hds @@ cards_ez first_owner n in basic 99 1000 cards (2 * n) in - Ast_simplified.assert_value_eq (expected_storage , storage) + Ast_simplified.Misc.assert_value_eq (expected_storage , storage) in let%bind () = let amount = Memory_proto_alpha.Alpha_context.Tez.zero in diff --git a/src/test/dune b/src/test/dune index 03a15c2e9..aebc6fad9 100644 --- a/src/test/dune +++ b/src/test/dune @@ -1,5 +1,5 @@ -(executable - (name test) +(executables + (names test manual_test) (libraries simple-utils ligo diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index a7be1fbb4..5a6f440df 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -2,7 +2,7 @@ open Trace open Ligo.Run open Test_helpers -let type_file = type_file "pascaligo" +let type_file = type_file `pascaligo let get_program = let s = ref None in diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 92e88ed1e..0a978b6e5 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -4,8 +4,8 @@ open Test_helpers open Ast_simplified.Combinators -let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed "cameligo" -let type_file = type_file "pascaligo" +let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed `cameligo +let type_file = type_file `pascaligo let type_alias () : unit result = let%bind program = type_file "./contracts/type-alias.ligo" in @@ -127,13 +127,70 @@ let arithmetic () : unit result = ("plus_op", fun n -> (n + 42)) ; ("minus_op", fun n -> (n - 42)) ; ("times_op", fun n -> (n * 42)) ; - (* ("div_op", fun n -> (n / 2)) ; *) + ("neg_op", fun n -> (-n)) ; ] in let%bind () = expect_eq_n_pos program "int_op" e_nat e_int in let%bind () = expect_eq_n_pos program "mod_op" e_int (fun n -> e_nat (n mod 42)) in let%bind () = expect_eq_n_pos program "div_op" e_int (fun n -> e_int (n / 2)) in ok () +let bitwise_arithmetic () : unit result = + let%bind program = type_file "./contracts/bitwise_arithmetic.ligo" in + let%bind () = expect_eq program "or_op" (e_nat 7) (e_nat 7) in + let%bind () = expect_eq program "or_op" (e_nat 3) (e_nat 7) in + let%bind () = expect_eq program "or_op" (e_nat 2) (e_nat 6) in + let%bind () = expect_eq program "or_op" (e_nat 14) (e_nat 14) in + let%bind () = expect_eq program "or_op" (e_nat 10) (e_nat 14) in + let%bind () = expect_eq program "and_op" (e_nat 7) (e_nat 7) in + let%bind () = expect_eq program "and_op" (e_nat 3) (e_nat 3) in + let%bind () = expect_eq program "and_op" (e_nat 2) (e_nat 2) in + let%bind () = expect_eq program "and_op" (e_nat 14) (e_nat 6) in + let%bind () = expect_eq program "and_op" (e_nat 10) (e_nat 2) in + let%bind () = expect_eq program "xor_op" (e_nat 0) (e_nat 7) in + let%bind () = expect_eq program "xor_op" (e_nat 7) (e_nat 0) in + ok () + +let string_arithmetic () : unit result = + let%bind program = type_file "./contracts/string_arithmetic.ligo" in + let%bind () = expect_eq program "concat_op" (e_string "foo") (e_string "foototo") in + let%bind () = expect_eq program "concat_op" (e_string "") (e_string "toto") in + let%bind () = expect_eq program "slice_op" (e_string "tata") (e_string "at") in + let%bind () = expect_eq program "slice_op" (e_string "foo") (e_string "oo") in + let%bind () = expect_fail program "slice_op" (e_string "ba") in + ok () + +let set_arithmetic () : unit result = + let%bind program = type_file "./contracts/set_arithmetic.ligo" in + let%bind () = + expect_eq program "add_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in + let%bind () = + expect_eq program "add_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in + let%bind () = + expect_eq program "remove_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program "remove_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program "mem_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_bool true) in + let%bind () = + expect_eq program "mem_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_bool false) in + let%bind () = + expect_eq program "iter_op" + (e_set [e_int 2 ; e_int 4 ; e_int 7]) + (e_int 13) in + ok () + let unit_expression () : unit result = let%bind program = type_file "./contracts/unit.ligo" in expect_eq_evaluate program "u" (e_unit ()) @@ -291,6 +348,16 @@ let map () : unit result = let expected = ez [23, 23] in expect_eq program "rm" input expected in + let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = e_int 66 in + expect_eq program "iter_op" input expected + in + let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in + expect_eq program "map_op" input expected + in ok () let list () : unit result = @@ -299,19 +366,29 @@ let list () : unit result = let lst' = List.map e_int lst in e_typed_list lst' t_int in + let%bind () = + let expected = ez [23 ; 42] in + expect_eq_evaluate program "fb" expected + in let%bind () = let make_input = fun n -> (ez @@ List.range n) in let make_expected = e_nat in expect_eq_n_strict_pos_small program "size_" make_input make_expected in - let%bind () = - let expected = ez [23 ; 42] in - expect_eq_evaluate program "fb" expected - in let%bind () = let expected = ez [144 ; 51 ; 42 ; 120 ; 421] in expect_eq_evaluate program "bl" expected in + let%bind () = + expect_eq program "iter_op" + (e_list [e_int 2 ; e_int 4 ; e_int 7]) + (e_int 13) + in + let%bind () = + expect_eq program "map_op" + (e_list [e_int 2 ; e_int 4 ; e_int 7]) + (e_list [e_int 3 ; e_int 5 ; e_int 8]) + in ok () let condition () : unit result = @@ -343,8 +420,7 @@ let loop () : unit result = let make_expected = fun n -> e_nat (n * (n + 1) / 2) in expect_eq_n_pos_mid program "sum" make_input make_expected in - ok() - + ok () let matching () : unit result = let%bind program = type_file "./contracts/match.ligo" in @@ -429,6 +505,16 @@ let super_counter_contract () : unit result = e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected +let super_counter_contract_mligo () : unit result = + let%bind program = mtype_file "./contracts/super-counter.mligo" in + let make_input = fun n -> + let action = if n mod 2 = 0 then "Increment" else "Decrement" in + e_pair (e_constructor action (e_int n)) (e_int 42) in + let make_expected = fun n -> + let op = if n mod 2 = 0 then (+) else (-) in + e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in + expect_eq_n program "main" make_input make_expected + let dispatch_counter_contract () : unit result = let%bind program = type_file "./contracts/dispatch-counter.ligo" in let make_input = fun n -> @@ -553,6 +639,9 @@ let main = test_suite "Integration (End to End)" [ test "multiple parameters" multiple_parameters ; test "bool" bool_expression ; test "arithmetic" arithmetic ; + test "bitiwse_arithmetic" bitwise_arithmetic ; + test "string_arithmetic" string_arithmetic ; + test "set_arithmetic" set_arithmetic ; test "unit" unit_expression ; test "string" string_expression ; test "option" option ; @@ -566,6 +655,7 @@ let main = test_suite "Integration (End to End)" [ test "#include directives" include_ ; test "counter contract" counter_contract ; test "super counter contract" super_counter_contract ; + test "super counter contract" super_counter_contract_mligo ; test "dispatch counter contract" dispatch_counter_contract ; test "closure" closure ; test "shared function" shared_function ; diff --git a/src/test/manual_test.ml b/src/test/manual_test.ml new file mode 100644 index 000000000..fdf8d4d8d --- /dev/null +++ b/src/test/manual_test.ml @@ -0,0 +1,17 @@ +open Trace +open Ligo.Run +open Test_helpers + +let syntax_error () : unit result = + let%bind _program = type_file `pascaligo "./contracts/error_syntax.ligo" in + ok () + +let type_error () : unit result = + let%bind _program = type_file `pascaligo "./contracts/error_type.ligo" in + ok () + +let () = + List.iter wrap_test_raw [ + type_error ; + syntax_error ; + ] diff --git a/src/test/test.ml b/src/test/test.ml index e07209be2..a3709700e 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -2,45 +2,6 @@ open Test_helpers -let rec test_height : test -> int = fun t -> - match t with - | Test _ -> 1 - | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1 - -let extract_test : test -> test_case = fun t -> - match t with - | Test tc -> tc - | _ -> assert false - -let extract_param : test -> (string * (string * test_case list) list) = - let extract_element = extract_test in - let extract_group : test -> (string * test_case list) = fun t -> - match t with - | Test tc -> ("isolated" , [ tc ]) - | Test_suite (name , lst) -> (name , List.map extract_element lst) in - fun t -> - match t with - | Test tc -> ("" , [ ("isolated" , [ tc ] ) ]) - | Test_suite (name , lst) -> (name , List.map extract_group lst) - -let x : _ -> (unit Alcotest.test) = fun x -> x - -(* - Alcotest.run parameters: - string * (string * f list) list -*) - -let rec run_test ?(prefix = "") : test -> unit = fun t -> - match t with - | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ] - | Test_suite (name , lst) -> ( - if (test_height t <= 3) then ( - let (name , tests) = extract_param t in - Alcotest.run (prefix ^ name) tests - ) else ( - List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst - ) - ) let () = (* Printexc.record_backtrace true ; *) @@ -51,6 +12,7 @@ let () = Typer_tests.main ; Heap_tests.main ; Coase_tests.main ; + Vote_tests.main ; Bin_tests.main ; ] ; () diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 5817845aa..071f8b271 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -5,50 +5,65 @@ type test = | Test_suite of (string * test list) | Test of test_case -let error_pp out (e : error) = - let open JSON_string_utils in - let message = - let opt = e |> member "message" |> string in - let msg = Option.unopt ~default:"" opt in - if msg = "" - then "" - else ": " ^ msg in - let error_code = - let error_code = e |> member "error_code" in - match error_code with - | `Null -> "" - | _ -> " (" ^ (J.to_string error_code) ^ ")" in - let title = - let opt = e |> member "title" |> string in - Option.unopt ~default:"" opt in - let data = - let data = e |> member "data" in - match data with - | `Null -> "" - | _ -> " " ^ (J.to_string data) ^ "\n" in - let infos = - let infos = e |> member "infos" in - match infos with - | `Null -> "" - | _ -> " " ^ (J.to_string infos) ^ "\n" in - Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos +let wrap_test name f = + let result = + trace (error (thunk "running test") (thunk name)) @@ + f () in + match result with + | Ok ((), annotations) -> ignore annotations; () + | Error err -> + Format.printf "%a\n%!" Ligo.Display.error_pp (err ()) ; + raise Alcotest.Test_error +let wrap_test_raw f = + match f () with + | Trace.Ok ((), annotations) -> ignore annotations; () + | Error err -> + Format.printf "%a\n%!" Ligo.Display.error_pp (err ()) + +(* let rec error_pp out (e : error) = + * let open JSON_string_utils in + * let message = + * let opt = e |> member "message" |> string in + * let msg = Option.unopt ~default:"" opt in + * if msg = "" + * then "" + * else ": " ^ msg in + * let error_code = + * let error_code = e |> member "error_code" in + * match error_code with + * | `Null -> "" + * | _ -> " (" ^ (J.to_string error_code) ^ ")" in + * let title = + * let opt = e |> member "title" |> string in + * Option.unopt ~default:"" opt in + * let data = + * let data = e |> member "data" in + * match data with + * | `Null -> "" + * | _ -> " " ^ (J.to_string data) ^ "\n" in + * let infos = + * let infos = e |> member "infos" in + * match infos with + * | `Null -> "" + * | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst + * | _ -> " " ^ (J.to_string infos) ^ "\n" in + * let children = + * let children = e |> member "children" in + * match children with + * | `Null -> "" + * | `List lst -> Format.asprintf "@[%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst + * | _ -> " " ^ (J.to_string children) ^ "\n" in + * Format.fprintf out "%s%s%s.\n%s%s%s" title error_code message data infos children *) let test name f = Test ( Alcotest.test_case name `Quick @@ fun () -> - let result = - trace (fun () -> error (thunk "running test") (thunk name) ()) @@ - f () in - match result with - | Ok ((), annotations) -> ignore annotations; () - | Error err -> - Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ; - raise Alcotest.Test_error + wrap_test name f ) let test_suite name lst = Test_suite (name , lst) - + open Ast_simplified.Combinators let expect ?options program entry_point input expecter = @@ -61,6 +76,17 @@ let expect ?options program entry_point input expecter = Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in expecter result +let expect_fail ?options program entry_point input = + let run_error = + let title () = "expect run" in + let content () = Format.asprintf "Entry_point: %s" entry_point in + error title content + in + trace run_error @@ + Assert.assert_fail + @@ Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input + + let expect_eq ?options program entry_point input expected = let expecter = fun result -> let expect_error = @@ -70,7 +96,7 @@ let expect_eq ?options program entry_point input expected = Ast_simplified.PP.expression result in error title content in trace expect_error @@ - Ast_simplified.assert_value_eq (expected , result) in + Ast_simplified.Misc.assert_value_eq (expected , result) in expect ?options program entry_point input expecter let expect_evaluate program entry_point expecter = @@ -79,12 +105,12 @@ let expect_evaluate program entry_point expecter = let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace error @@ - let%bind result = Ligo.Run.evaluate_simplityped program entry_point in + let%bind result = Ligo.Run.evaluate_simplityped ~debug_mini_c:true ~debug_michelson:true program entry_point in expecter result let expect_eq_evaluate program entry_point expected = let expecter = fun result -> - Ast_simplified.assert_value_eq (expected , result) in + Ast_simplified.Misc.assert_value_eq (expected , result) in expect_evaluate program entry_point expecter let expect_n_aux ?options lst program entry_point make_input make_expecter = @@ -134,3 +160,44 @@ let expect_eq_n_int a b c = let expect_eq_b_bool a b c = let open Ast_simplified.Combinators in expect_eq_b a b (fun bool -> e_bool (c bool)) + + +let rec test_height : test -> int = fun t -> + match t with + | Test _ -> 1 + | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1 + +let extract_test : test -> test_case = fun t -> + match t with + | Test tc -> tc + | _ -> assert false + +let extract_param : test -> (string * (string * test_case list) list) = + let extract_element = extract_test in + let extract_group : test -> (string * test_case list) = fun t -> + match t with + | Test tc -> ("isolated" , [ tc ]) + | Test_suite (name , lst) -> (name , List.map extract_element lst) in + fun t -> + match t with + | Test tc -> ("" , [ ("isolated" , [ tc ] ) ]) + | Test_suite (name , lst) -> (name , List.map extract_group lst) + +let x : _ -> (unit Alcotest.test) = fun x -> x + +(* + Alcotest.run parameters: + string * (string * f list) list +*) + +let rec run_test ?(prefix = "") : test -> unit = fun t -> + match t with + | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ] + | Test_suite (name , lst) -> ( + if (test_height t <= 3) then ( + let (name , tests) = extract_param t in + Alcotest.run (prefix ^ name) tests + ) else ( + List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst + ) + ) diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml new file mode 100644 index 000000000..d4d1f9336 --- /dev/null +++ b/src/test/vote_tests.ml @@ -0,0 +1,55 @@ +open Trace +open Ligo.Run +open Test_helpers + +let get_program = + let s = ref None in + fun () -> match !s with + | Some s -> ok s + | None -> ( + let%bind program = type_file `cameligo "./contracts/vote.mligo" in + s := Some program ; + ok program + ) + +open Ast_simplified + +let init_storage name = ez_e_record [ + ("title" , e_string name) ; + ("candidates" , e_map [ + (e_string "Yes" , e_int 0) ; + (e_string "No" , e_int 0) ; + ]) ; + ("voters" , e_typed_set [] t_address) ; + ("beginning_time" , e_timestamp 0) ; + ("finish_time" , e_timestamp 1000000000) ; + ] + +let init title beginning_time finish_time = + let init_action = ez_e_record [ + ("title" , e_string title) ; + ("beginning_time" , e_timestamp beginning_time) ; + ("finish_time" , e_timestamp finish_time) ; + ] in + e_constructor "Init" init_action + +let vote str = + let vote = e_string str in + e_constructor "Vote" vote + +let init_vote () = + let%bind program = get_program () in + let%bind result = Ligo.Run.run_simplityped program "main" (e_pair (vote "Yes") (init_storage "basic")) in + let%bind (_ , storage) = extract_pair result in + let%bind storage' = extract_record storage in + let votes = List.assoc "candidates" storage' in + let%bind votes' = extract_map votes in + let%bind (_ , yess) = + trace_option (simple_error "") @@ + List.find_opt (fun (k , _) -> Ast_simplified.Misc.is_value_eq (k , e_string "Yes")) votes' in + let%bind () = Ast_simplified.Misc.assert_value_eq (yess , e_int 1) in + ok () + +let main = test_suite "Vote" [ + test "type" init_vote ; + ] diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 724a32b32..3aed3edb5 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -32,12 +32,22 @@ them. please report this to the developers." in let content () = name in error title content + let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l) + let unsupported_pattern_matching kind location = let title () = "unsupported pattern-matching" in let content () = Format.asprintf "%s patterns aren't supported yet" kind in let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in + row_loc location ; + ] in + error ~data title content + + let unsupported_iterator location = + let title () = "unsupported iterator" in + let content () = "only lambda are supported as iterators" in + let data = [ + row_loc location ; + ] in error ~data title content let not_functional_main location = @@ -105,6 +115,9 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("list", [t]) -> let%bind t' = translate_type t in ok (T_list t') + | T_constant ("set", [t]) -> + let%bind t' = translate_type t in + ok (T_set t') | T_constant ("option", [o]) -> let%bind o' = translate_type o in ok (T_option o') @@ -181,6 +194,7 @@ let rec translate_literal : AST.literal -> value = fun l -> match l with | Literal_bool b -> D_bool b | Literal_int n -> D_int n | Literal_nat n -> D_nat n + | Literal_timestamp n -> D_timestamp n | Literal_tez n -> D_tez n | Literal_bytes s -> D_bytes s | Literal_string s -> D_string s @@ -337,15 +351,50 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind record' = translate_annotated_expression record in let expr = List.fold_left aux record' path in ok expr - | E_constant (name, lst) -> ( - let%bind lst' = bind_map_list (translate_annotated_expression) lst in - match name, lst with - | "NONE", [] -> - let%bind o = - trace_strong (corner_case ~loc:__LOC__ "not an option") @@ - Mini_c.Combinators.get_t_option tv in - return @@ E_make_none o - | _ -> return @@ E_constant (name, lst') + | E_constant (name , lst) -> ( + let (iter , map) = + let iterator name = fun (lst : AST.annotated_expression list) -> match lst with + | [i ; f] -> ( + let%bind f' = match f.expression with + | E_lambda l -> ( + let%bind body' = translate_annotated_expression l.result in + let%bind input' = translate_type l.input_type in + ok ((l.binder , input') , body') + ) + | E_variable v -> ( + let%bind elt = + trace_option (corner_case ~loc:__LOC__ "missing var") @@ + AST.Environment.get_opt v f.environment in + match elt.definition with + | ED_declaration (f , _) -> ( + match f.expression with + | E_lambda l -> ( + let%bind body' = translate_annotated_expression l.result in + let%bind input' = translate_type l.input_type in + ok ((l.binder , input') , body') + ) + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + in + let%bind i' = translate_annotated_expression i in + return @@ E_iterator (name , f' , i') + ) + | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity" + in + iterator "ITER" , iterator "MAP" in + match (name , lst) with + | ("SET_ITER" , lst) -> iter lst + | ("LIST_ITER" , lst) -> iter lst + | ("MAP_ITER" , lst) -> iter lst + | ("LIST_MAP" , lst) -> map lst + | ("MAP_MAP" , lst) -> map lst + | _ -> ( + let%bind lst' = bind_map_list (translate_annotated_expression) lst in + return @@ E_constant (name , lst') + ) ) | E_lambda l -> let%bind env = @@ -360,6 +409,16 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let aux : expression -> expression -> expression result = fun prev cur -> return @@ E_constant ("CONS", [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") @@ + Mini_c.Combinators.get_t_set tv in + let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let aux : expression -> expression -> expression result = fun prev cur -> + return @@ E_constant ("SET_ADD", [cur ; prev]) in + let%bind (init : expression) = return @@ E_make_empty_set t in bind_fold_list aux init lst' ) | E_map m -> ( @@ -525,7 +584,7 @@ and translate_lambda env l = let%bind output = translate_type output_type in let tv = Combinators.t_function input output in let content = D_function {binder;input;output;result=result'} in - ok @@ Combinators.Expression.make_tpl (E_literal content, tv) + ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( translate_lambda_deep env l @@ -660,9 +719,15 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression | T_constant ("nat", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "nat" v) @@ - get_nat v in + get_nat v in return (E_literal (Literal_nat n)) ) + | T_constant ("timestamp", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "timestamp" v) @@ + get_timestamp v in + return (E_literal (Literal_timestamp n)) + ) | T_constant ("tez", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "tez" v) @@ @@ -712,6 +777,15 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_list lst') ) + | T_constant ("set", [ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "set" v) @@ + get_set v in + let%bind lst' = + let aux = fun e -> untranspile e ty in + bind_map_list aux lst in + return (E_set lst') + ) | T_constant ("contract" , [_ty]) -> fail @@ bad_untranspile "contract" v | T_constant ("operation" , []) -> ( diff --git a/src/typer/typer.ml b/src/typer/typer.ml index a3f0f0140..5c962cc10 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -206,11 +206,13 @@ module Errors = struct ] in error ~data title message () - let constant_error loc = + let constant_error loc lst tv_opt = let title () = "typing constant" in let message () = "" in let data = [ ("location" , fun () -> Format.asprintf "%a" Location.pp loc ) ; + ("argument_types" , fun () -> Format.asprintf "%a" PP_helpers.(list_sep Ast_typed.PP.type_value (const " , ")) lst) ; + ("type_opt" , fun () -> Format.asprintf "%a" PP_helpers.(option Ast_typed.PP.type_value) tv_opt) ; ] in error ~data title message end @@ -416,6 +418,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_literal (Literal_int n)) (t_int ()) | E_literal (Literal_nat n) -> return (E_literal (Literal_nat n)) (t_nat ()) + | E_literal (Literal_timestamp n) -> + return (E_literal (Literal_timestamp n)) (t_timestamp ()) | E_literal (Literal_tez n) -> return (E_literal (Literal_tez n)) (t_tez ()) | E_literal (Literal_address s) -> @@ -501,6 +505,27 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a 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 = @@ -613,7 +638,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ae.location) @@ assert_t_unit (get_type_annotation mf') in let mt' = make_a_e - (E_constant ("ASSERT" , [ex' ; fw'])) + (E_constant ("ASSERT_INFERRED" , [ex' ; fw'])) (t_unit ()) e in @@ -738,7 +763,7 @@ and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value opt let%bind typer = trace_option (unrecognized_constant name loc) @@ Map.String.find_opt name ct in - trace (constant_error loc) @@ + trace (constant_error loc lst tv_opt) @@ typer lst tv_opt let untype_type_value (t:O.type_value) : (I.type_expression) result = @@ -752,6 +777,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_unit -> ok Literal_unit | Literal_bool b -> ok (Literal_bool b) | Literal_nat n -> ok (Literal_nat n) + | Literal_timestamp n -> ok (Literal_timestamp n) | Literal_tez n -> ok (Literal_tez n) | Literal_int n -> ok (Literal_int n) | Literal_string s -> ok (Literal_string s) @@ -803,6 +829,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | 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) diff --git a/vendors/ligo-utils/proto-alpha-utils/trace.ml b/vendors/ligo-utils/proto-alpha-utils/trace.ml index 53cffe354..812ce0405 100644 --- a/vendors/ligo-utils/proto-alpha-utils/trace.ml +++ b/vendors/ligo-utils/proto-alpha-utils/trace.ml @@ -26,10 +26,12 @@ let trace_tzresult err = let trace_tzresult_r err_thunk_may_fail = function | Result.Ok x -> ok x - | Error _errs -> - (* let tz_errs = List.map of_tz_error errs in *) + | Error errs -> + let tz_errs = List.map of_tz_error errs in match err_thunk_may_fail () with - | Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Error (err) + | Simple_utils.Trace.Ok (err, annotations) -> + ignore annotations ; + Error (fun () -> patch_children tz_errs (err ())) | Error errors_while_generating_error -> (* TODO: the complexity could be O(n*n) in the worst case, this should use some catenable lists. *) diff --git a/vendors/ligo-utils/simple-utils/dune b/vendors/ligo-utils/simple-utils/dune index 6a0556a18..1cc6b0f37 100644 --- a/vendors/ligo-utils/simple-utils/dune +++ b/vendors/ligo-utils/simple-utils/dune @@ -1,6 +1,8 @@ (library (name simple_utils) (public_name simple-utils) + (preprocess + (pps simple-utils.ppx_let_generalized)) (libraries yojson unix diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 582347eae..d183f38d4 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -1,7 +1,220 @@ +(** Trace tutorial + + The module below guides the reader through the writing of a + simplified version of the trace monad (`result`), and the + definition of a few operations that make it easier to work with + `result`. +*) + +module Trace_tutorial = struct +(** The trace monad is fairly similar to the option type: *) + +type 'a option = + Some of 'a (* Ok also stores a list of annotations *) + | None;; (* Errors also stores a list of messages *) + +type annotation = string;; +type error = string;; +type 'a result = + Ok of 'a * annotation list + | Errors of error list;; + +(** When applying a partial function on a result, it can return a valid result + (Some v), or indicate failure (None). *) + +let divide a b = + if b = 0 + then None + else Some (a/b);; + +(** With the trace monad, the Errors case also indicates some information about + the failure, to ease debugging. *) + +let divide_trace a b = + if b = 0 + then (Errors [Printf.sprintf "division by zero: %d / %d" a b]) + else Ok ((a/b) , []);; + +(** when composing two functions, the error case is propagated. *) + +let divide_three a b c = + let maybe_a_div_b = divide_trace a b in + match maybe_a_div_b with + Ok (a_div_b , _) -> divide_trace a_div_b c + | (Errors _) as e -> e;; + +(** If both calls are successful, the lists of annotations are concatenated. *) + +let divide_three_annots a b c = + let maybe_a_div_b = divide_trace a b in + match maybe_a_div_b with + Ok (a_div_b , annots1) -> + let maybe_a_div_b_div_c = divide_trace a_div_b c in + begin + match maybe_a_div_b_div_c with + Ok (a_div_b_div_c , annots2) + -> Ok (a_div_b_div_c , annots2 @ annots1) + | (Errors _) as e2 -> e2 + end + | (Errors _) as e1 -> e1;; + +(** This incurs quite a lot of noise, so we define a `bind` operator which + takes a function ('x -> ('y result)) and applies it to an existing + ('x result). + + * If the existing result is Errors, `bind` returns that error without + calling the function + * Otherwise `bind` unwraps the Ok and calls the function + * That function may itself return an error + * Otherwise `bind` combines the annotations and returns the second + result. *) + +let bind f = function + | Ok (x, annotations) -> + (match f x with + Ok (x', annotations') -> Ok (x', annotations' @ annotations) + | Errors _ as e' -> ignore annotations; e') + | Errors _ as e -> e;; + +(** The following function divide_three_bind is equivalent to the verbose + divide_three. *) + +let divide_three_bind a b c = + let maybe_a_div_b = divide_trace a b in + let continuation a_div_b = divide_trace a_div_b c in + bind continuation maybe_a_div_b;; + +(** This made the code shorter, but the reading order is a bit awkward. + We define an operator symbol for `bind`: *) + +let (>>?) x f = bind f x;; + +let divide_three_bind_symbol a b c = + let maybe_a_div_b = divide_trace a b in + let continuation a_div_b = divide_trace a_div_b c in + maybe_a_div_b >>? continuation;; + +(** and we inline the two temporary let definitions: *) + +let divide_three_bind_symbol' a b c = + divide_trace a b >>? (fun a_div_b -> divide_trace a_div_b c);; + +(** This is now fairly legible, but chaining many such functions is + not the usual way of writing code. We use ppx_let to add some + syntactic sugar. + + The ppx is enabled by adding the following lines inside the + section (library …) or (executable …) of the dune file for + the project that uses ppx_let. + + (preprocess + (pps simple-utils.ppx_let_generalized)) +*) + +module Let_syntax = struct + let bind m ~f = m >>? f + module Open_on_rhs_bind = struct end +end;; + +(** divide_three_bind_ppx_let is equivalent to divide_three_bind_symbol'. + + Strictly speaking, the only difference is that the module + Open_on_rhs_bind is opened around the expression on the righ-hand side + of the `=` sign, namely `divide_trace a b` *) + +let divide_three_bind_ppx_let a b c = + let%bind a_div_b = divide_trace a b in + divide_trace a_div_b c;; + +(** This notation scales fairly well: *) + +let divide_many_bind_ppx_let a b c d e f = + let x = a in + let%bind x = divide_trace x b in + let%bind x = divide_trace x c in + let%bind x = divide_trace x d in + let%bind x = divide_trace x e in + let%bind x = divide_trace x f in + Ok (x , []);; + +(** We define a couple of shorthands for common use cases. + + `ok` lifts a ('foo) value to a ('foo result): *) + +let ok x = Ok (x, []);; + +(** `map` lifts a regular ('foo -> 'bar) function on values + to a function on results, with type ('foo result -> 'bar result): *) + +let map f = function + | Ok (x, annotations) -> Ok (f x, annotations) + | Errors _ as e -> e;; + +(** `bind_list` turns a (('foo result) list) into a (('foo list) result). + + If the list only contains Ok values, it strips the Ok returns that list + wrapped with Ok. + + Otherwise, when one or more of the elements of the original list is + Errors, `bind_list` returns the first error in the list. *) + +let rec bind_list = function + | [] -> ok [] + | hd :: tl -> ( + hd >>? fun hd -> + bind_list tl >>? fun tl -> + ok @@ hd :: tl + );; + +(** + A major feature of Trace is that it enables having a stack of errors (that + should act as a simplified stack frame), rather than a unique error. + It is done by using the function `trace`. + For instance, let's say that you have a function that can trigger two errors, + and you want to pass their data along with an other error, what you would + usually do is: + ``` + let foobarer ... = + ... in + let value = + try ( get key map ) + with + | Bad_key _ -> raise (Foobar_error ("bad key" , key , map)) + | Missing_value _ -> raise (Foobar_error ("missing index" , key , map)) + in ... + ``` + With Trace, you would instead: + ``` + let foobarer ... = + ... in + let%bind value = + trace (simple_error "error getting key") @@ + get key map + in ... + ``` + And this will pass along the error triggered by "get key map". +*) + +let trace err = function + | Ok _ as o -> o + | Errors errs -> Errors (err :: errs);; + +(** The real trace monad is very similar to the one that we have + defined above. The main difference is that the errors and + annotations are structured data (instead of plain strings) and are + lazily-generated. *) + +let the_end = "End of the tutorial.";; + +end (* end Trace_tutorial. *) + module J = Yojson.Basic module JSON_string_utils = struct - let member = J.Util.member + let member = fun n x -> + match x with + | `Null -> `Null + | x -> J.Util.member n x let string = J.Util.to_string_option let to_list_option = fun x -> try ( Some (J.Util.to_list x)) @@ -208,34 +421,6 @@ let internal_assertion_failure str = simple_error ("assertion failed: " ^ str) *) let dummy_fail = simple_fail "dummy" -(** - A major feature of Trace is that it enables having a stack of errors (that - should act as a simplified stack frame), rather than a unique error. - It is done by using the function `trace`. - For instance, let's say that you have a function that can trigger two errors, - and you want to pass their data along with an other error, what you would - usually do is: - ``` - let foobarer ... = - ... in - let value = - try ( get key map ) - with - | Bad_key _ -> raise (Foobar_error ("bad key" , key , map)) - | Missing_value _ -> raise (Foobar_error ("missing index" , key , map)) - in ... - ``` - With Trace, you would instead: - ``` - let foobarer ... = - ... in - let%bind value = - trace (simple_error "error getting key") @@ - get key map - in ... - ``` - And this will pass along the error triggered by "get key map". -*) let trace info = function | Ok _ as o -> o | Error err -> Error (fun () -> prepend_info (info ()) (err ())) diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 5222abd63..254b93fab 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -47,6 +47,9 @@ let i_push_unit = i_push t_unit d_unit let i_push_string str = i_push t_string (string str) let i_none ty = prim ~children:[ty] I_NONE let i_nil ty = prim ~children:[ty] I_NIL +let i_empty_set ty = prim ~children:[ty] I_EMPTY_SET +let i_iter body = prim ~children:[body] I_ITER +let i_map body = prim ~children:[body] I_MAP let i_some = prim I_SOME let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP diff --git a/vendors/opam-repository-tools/rewrite-local-opam-repository.sh b/vendors/opam-repository-tools/rewrite-local-opam-repository.sh index 01b196df9..8771aa7bd 100755 --- a/vendors/opam-repository-tools/rewrite-local-opam-repository.sh +++ b/vendors/opam-repository-tools/rewrite-local-opam-repository.sh @@ -1,13 +1,55 @@ -#!/bin/bash -set -euET -o pipefail -main(){ - root_dir="$(pwd | sed -e 's/\\/\\\\/' | sed -e 's/&/\\\&/' | sed -e 's/~/\\~/')" - rm -fr vendors/ligo-opam-repository-local-generated - mkdir vendors/ligo-opam-repository-local-generated - cp -a index.tar.gz packages repo urls.txt vendors/ligo-opam-repository-local-generated - cd vendors/ligo-opam-repository-local-generated - grep -r --null -l src: | grep -z 'opam$' | xargs -0 \ - sed -i -e 's~src: *"https://gitlab.com/ligolang/ligo/-/archive/master/ligo\.tar\.gz"~src: "file://'"$root_dir"'"~' - # TODO: run the update.sh script adequately to regenerate the index.tar.gz etc. in the local repo -} -if main; then exit 0; else exit $?; fi +#!/bin/sh + +# Stop on error. +set -e + +# Defensive checks. We're going to remove an entire folder so this script is somewhat dangerous. Better check in advance what can go wrong in the entire execution of the script. +if test -e index.tar.gz && test -e packages && test -e repo && test -e urls.txt; then + if test -d vendors/; then + if test -d "$PWD"; then + if command -v sed >/dev/null 2>&1 \ + && command -v rm >/dev/null 2>&1 \ + && command -v mkdir >/dev/null 2>&1 \ + && command -v cp >/dev/null 2>&1 \ + && command -v find >/dev/null 2>&1 \ + && command -v xargs >/dev/null 2>&1 \ + && command -v opam >/dev/null 2>&1; then + + # Escape the current directory, to be used as the replacement part of the sed regular expression + escaped_project_root="$(printf %s "$PWD" | sed -e 's/\\/\\\\/' | sed -e 's/&/\\\&/' | sed -e 's/~/\\~/')" + + # Recreate vendors/ligo-opam-repository-local-generated which contains a copy of the files related to the opam repository + rm -fr vendors/ligo-opam-repository-local-generated + mkdir vendors/ligo-opam-repository-local-generated + cp -pR index.tar.gz packages repo urls.txt vendors/ligo-opam-repository-local-generated + + # Rewrite the URLs in the opam repository to point to the project root + ( + cd vendors/ligo-opam-repository-local-generated + find . -type f -name opam -print0 | xargs -0 sed -i -e 's~src: *"https://gitlab.com/ligolang/ligo/-/archive/master/ligo\.tar\.gz"~src: "file://'"$escaped_project_root"'"~' + ) + + # Regenerate the index.tar.gz etc. in the local repo + ( + cd vendors/ligo-opam-repository-local-generated + opam admin index + opam admin cache + ) + else + echo "One of the following commands is unavailable: sed rm mkdir cp find xargs opam." + exit 1 + fi + else + echo "Unable to access the current directory as indicated by PWD. Was the CWD of the current shell removed?" + exit 1 + fi + + else + echo "Cannot find the directory vendors/ in the current directory" + exit 1 + fi +else + echo "Cannot find some of the following files in the current directory" + echo "index.tar.gz packages repo urls.txt" + exit 1 +fi