balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge remote-tracking branch 'origin/dev' into rinderknecht-dev

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-09-26 17:11:08 +02:00
commit 68ff421b7d
1753 changed files with 7469 additions and 196859 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View File

@ -1,5 +1,8 @@
/_build/
/dune-project
dune-project
*~
*.merlin
cache/*
Version.ml
/_opam/
/*.pp.ligo

78
.gitlab-ci.yml
View File

@ -13,34 +13,17 @@ stages:
image: node:8
before_script:
- 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
- scripts/install_opam.sh # TODO: or scripts/install_build_environment.sh ?
- export PATH="/usr/local/bin${PATH:+:}${PATH:-}"
# Initialise opam
- printf '' | opam init --bare
- eval $(opam config env)
# Create switch
- printf '' | opam switch create toto ocaml-base-compiler.4.06.1
- scripts/setup_switch.sh
- eval $(opam config env)
# Show versions and current switch
- echo "$PATH"
- opam --version
- printf '' | ocaml
- opam switch
- scripts/setup_repos.sh
# install deps for internal documentation
- scripts/install_vendors_deps.sh
- 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)
- scripts/build_ligo_local.sh
# build with odoc
- dune build @doc
@ -67,52 +50,26 @@ stages:
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
- scripts/install_opam.sh # TODO: or scripts/install_build_environment.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
- scripts/setup_switch.sh
- eval $(opam config env)
- scripts/setup_repos.sh
local-dune-job:
<<: *before_script
stage: test
script:
- 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:
#- (cd ./src/; dune build -p ligo)
- scripts/install_vendors_deps.sh
- scripts/build_ligo_local.sh
- dune build @ligo-test
# artifacts:
# paths:
# - src/ligo/bin/cli.ml
local-repo-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/"
#--build-test
- opam install -y ligo
remote-repo-job:
<<: *before_script
@ -130,11 +87,15 @@ remote-repo-job:
only:
- master
# TODO: uncomment this
# Run a docker build without publishing to the registry
build-current-docker-image:
stage: build_docker
<<: *docker
<<: *docker_build
script:
- docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile .
- sh scripts/test_cli.sh
except:
- master
- dev
@ -144,14 +105,14 @@ build-current-docker-image:
build-and-publish-latest-docker-image:
stage: build_and_deploy_docker
<<: *docker
<<: *docker_build
after_script:
script:
- docker build -t $LIGO_REGISTRY_IMAGE:next -f ./docker/Dockerfile .
- sh scripts/test_cli.sh
- docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD
- docker push $LIGO_REGISTRY_IMAGE:next
only:
- dev
# Pages are deployed from both master & dev, be careful not to override 'next'
# in case something gets merged into 'dev' while releasing.
pages:
@ -159,4 +120,3 @@ pages:
only:
- master
- dev
- feature/website-fixes

32
Makefile
View File

@ -1,3 +1,31 @@
.ONESHELL:
all: test
# Use install-deps instead of 'install' because usually 'make install' adds a
# binary to the system path and we don't want to confuse users
install-deps:
# Install ligo/tezos specific system-level dependencies
sudo scripts/install_native_dependencies.sh
scripts/install_build_environment.sh # TODO: or scripts/install_opam.sh ?
build-deps:
scripts/install_native_dependencies.sh
scripts/install_opam.sh
export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
# Create opam dev switch locally for use with Ligo, add merlin/etc
if [ -n "`opam switch show | grep -P ".+/ligo"`" ];
then :; else scripts/setup_dev_switch.sh;
fi
eval $$(opam config env)
# Install OCaml build dependencies for Ligo
scripts/install_vendors_deps.sh
build: build-deps
export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
eval $$(opam config env)
# Build Ligo for local dev use
scripts/build_ligo_local.sh
test: build
export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
eval $$(opam config env)
scripts/test_ligo.sh

18
docker/Dockerfile
View File

@ -1,6 +1,5 @@
# We could use one of the nomadiclab's docker images as a base instead
# We're using 4.06 instead of 4.06.1, if this causes problems build a custom 4.06.1 image instead
FROM ocaml/opam2:4.06
# At the moment, this really means 4.07.1
FROM ocaml/opam2:4.07
USER root
@ -19,13 +18,18 @@ WORKDIR /ligo
# 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
# Install OPAM
# TODO: or scripts/install_build_environment.sh ?
RUN sh scripts/install_opam.sh
# Add tezos repository
RUN sh scripts/setup_repos.sh
RUN opam update
# Install ligo
RUN sh scripts/install_ligo_with_dependencies.sh
RUN sh scripts/install_vendors_deps.sh
RUN opam install -y ./src
# Use the ligo binary as a default command
ENTRYPOINT [ "/home/opam/.opam/4.06/bin/ligo" ]
ENTRYPOINT [ "/home/opam/.opam/4.07/bin/ligo" ]

6
gitlab-pages/website/pages/en/versions.js
View File

@ -18,15 +18,13 @@ const versions = require(`${CWD}/versions.json`);
function Versions(props) {
const {config: siteConfig} = props;
const latestVersion = versions[0];
const repoUrl = `https://github.com/${siteConfig.organizationName}/${
siteConfig.projectName
}`;
const repoUrl = `${siteConfig.repoUrl}`;
return (
<div className="docMainWrapper wrapper">
<Container className="mainContainer versionsContainer">
<div className="post">
<header className="postHeader">
<h1>{siteConfig.title} Versions</h1>
<h1>{siteConfig.title} Versions </h1>
</header>
<h3 id="latest">Current version</h3>
<table className="versions">

25
makefile
View File

@ -1,25 +0,0 @@
# Use install-deps instead of 'install' because usually 'make install' adds a
# binary to the system path and we don't want to confuse users
install-deps:
# Install ligo/tezos specific system-level dependencies
sudo scripts/install_native_dependencies.sh
build-deps:
# Create opam dev switch locally for use with Ligo, add merlin/etc
if [ -n "`opam switch show | grep -P ".+/ligo"`" ];
then exit; else scripts/setup_dev_switch.sh;
fi
# Set up the local ligo opam repository so that it can be built
if [ -n "`opam repo list --safe | grep -P "ligo-opam-repository"`" ];
then exit; else scripts/setup_ligo_opam_repository.sh;
fi
# Install OCaml build dependencies for Ligo
scripts/install_ligo_with_dependencies.sh
build: build-deps
# Build Ligo for local dev use
scripts/build_ligo_local.sh
.ONESHELL:
test: build
scripts/test_ligo.sh

8
scripts/build_ligo_local.sh
View File

@ -1,2 +1,8 @@
eval $(opam env)
#!/bin/sh
set -e
eval $(opam config env)
dune build -p ligo
# TODO: also try instead from time to time:
#- (cd ./src/; dune build -p ligo)

3
scripts/install_build_environment.sh
View File

@ -1,3 +1,6 @@
#!/bin/sh
set -e
# This script installs opam for the user. It should NOT be included in any makefiles/etc.
if [ -n "`which opam`" ]

5
scripts/install_ligo_with_dependencies.sh
View File

@ -1,5 +0,0 @@
#!/bin/sh
set -e
cd src
opam install . --yes

19
scripts/install_opam.sh
View File

@ -1,10 +1,27 @@
#!/bin/sh
set -e
set -x
# 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
if command -v wget >/dev/null 2>&1; then
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
else
curl -L https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux --output temp.opam-2.0.1-x86_64-linux.download-in-progress
fi
# debug
ls
apt -y install hexdump || true
apt -y install xxd || true
(cat temp.opam-2.0.1-x86_64-linux.download-in-progress | xxd | head -n 30) || true
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
which opam || true
opam init -a --bare

6
scripts/install_vendors_deps.sh Executable file
View File

@ -0,0 +1,6 @@
#!/bin/sh
set -e
# Install local dependencies
opam install -y --deps-only --with-test $(find src vendors -name \*.opam)
opam install -y $(find vendors -name \*.opam)

1
scripts/ligo_ci.sh Executable file
View File

@ -0,0 +1 @@
docker run -i -v "$PWD":"$PWD" -w "$PWD" ligolang/ligo:next "$@"

8
scripts/setup_dev_switch.sh
View File

@ -1,4 +1,8 @@
opam switch create . ocaml-base-compiler.4.06.1
eval $(opam env)
#!/bin/sh
set -e
"$(dirname "$0")"/setup_switch.sh
"$(dirname "$0")"/setup_repos.sh
opam install -y ocp-indent tuareg merlin alcotest-lwt crowbar
opam -y user-setup install

11
scripts/setup_repos.sh Executable file
View File

@ -0,0 +1,11 @@
#!/bin/sh
set -e
set -x
eval $(opam config env)
# Remove the nomadic-labs tezos repo (from ligo switch only)
opam repository remove tezos-opam-repository
# Add ligolang tezos repo
opam repository add ligolang-tezos-opam-repository https://gitlab.com/ligolang/tezos-opam-repository.git

6
scripts/setup_switch.sh Executable file
View File

@ -0,0 +1,6 @@
#!/bin/sh
set -e
set -x
printf '' | opam switch create . 4.07.1 # toto ocaml-base-compiler.4.06.1
eval $(opam config env)

29
scripts/test_cli.sh Executable file
View File

@ -0,0 +1,29 @@
#!/bin/sh
set -e
compiled_contract=$(./scripts/ligo_ci.sh compile-contract src/test/contracts/website2.ligo main);
compiled_storage=$(./scripts/ligo_ci.sh compile-storage src/test/contracts/website2.ligo main 1);
compiled_parameter=$(./scripts/ligo_ci.sh compile-parameter src/test/contracts/website2.ligo main "Increment(1)");
dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo main "Increment(1)" 1);
expected_compiled_parameter="(Right 1)";
expected_compiled_storage=1;
expected_dry_run_output="tuple[ list[]
2
]";
if [ "$compiled_storage" != "$expected_compiled_storage" ]; then
echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead";
exit 1;
fi
if [ "$compiled_parameter" != "$expected_compiled_parameter" ]; then
echo "Expected $expected_compiled_parameter as compile-parameter output, got $compiled_parameter instead";
exit 1;
fi
if [ "$dry_run_output" != "$expected_dry_run_output" ]; then
echo "Expected $expected_dry_run_output as dry-run output, got $dry_run_output instead";
exit 1;
fi
echo "CLI tests passed";

5
scripts/test_ligo.sh
View File

@ -1,2 +1,5 @@
eval $(opam env)
#!/bin/sh
set -e
eval $(opam config env)
dune build @ligo-test

20
src/README_INSTALL
View File

@ -1,20 +0,0 @@
switch=titi
cd src/ligo
sudo apt -y install libev-dev libhidapi-dev
opam init
eval $(opam env)
opam switch create $switch ocaml-base-compiler.4.06.1
eval $(opam env --switch=$switch --set-switch)
opam repository add new-tezos https://gitlab.com/ligolang/new-tezos-opam-repository.git
# si une build a déjà été tentée, il vaut mieux git add tout ce qui est utile et git clean -dfx pour supprimer tout le reste (dune 1.7 crée des fichiers non compatibles avec dune 1.6)
opam install -y ocplib-endian alcotest
(cd ligo-parser && opam install -y .)
eval $(opam env)
(cd ligo-helpers && opam install -y .)
eval $(opam env)
(opam install -y .)
eval $(opam env)
opam install merlin ocp-indent ledit
opam user-setup install

106
src/bin/cli.ml
View File

@ -37,6 +37,14 @@ let syntax =
info ~docv ~doc ["syntax" ; "s"] in
value @@ opt string "auto" info
let bigmap =
let open Arg in
let info =
let docv = "BIGMAP" in
let doc = "$(docv) is necessary when your storage embeds a big_map." in
info ~docv ~doc ["bigmap"] in
value @@ flag info
let amount =
let open Arg in
let info =
@ -45,98 +53,124 @@ let amount =
info ~docv ~doc ["amount"] in
value @@ opt string "0" info
let display_format =
let open Arg in
let info =
let docv = "DISPLAY_FORMAT" in
let doc = "$(docv) is the format that will be used by the CLI. Available formats are 'dev', 'json', and 'human-readable' (default). When human-readable lacks details (we are still tweaking it), please contact us and use another format in the meanwhile." in
info ~docv ~doc ["format" ; "display-format"] in
value @@ opt string "human-readable" info
let michelson_code_format =
let open Arg in
let info =
let docv = "MICHELSON_FORMAT" in
let doc = "$(docv) is the format that will be used by compile-contract for the resulting Michelson. Available formats are 'micheline', and 'michelson' (default). Micheline is the format used by [XXX]." in
info ~docv ~doc ["michelson-format"] in
value @@ opt string "michelson" info
let compile_file =
let f source entry_point syntax =
toplevel @@
let f source entry_point syntax display_format michelson_format =
toplevel ~display_format @@
let%bind michelson_format = Main.Display.michelson_format_of_string michelson_format in
let%bind contract =
trace (simple_info "compiling contract to michelson") @@
Ligo.Run.compile_contract_file source entry_point (Syntax_name syntax) in
Format.printf "%s\n" contract ;
ok ()
Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract
in
let term =
Term.(const f $ source 0 $ entry_point 1 $ syntax) in
Term.(const f $ source 0 $ entry_point 1 $ syntax $ display_format $ michelson_code_format) in
let cmdname = "compile-contract" in
let docs = "Subcommand: compile a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in
(term , Term.info ~docs cmdname)
let compile_parameter =
let f source entry_point expression syntax =
toplevel @@
let f source entry_point expression syntax display_format =
toplevel ~display_format @@
let%bind value =
trace (simple_error "compile-input") @@
Ligo.Run.compile_contract_parameter source entry_point expression (Syntax_name syntax) in
Format.printf "%s\n" value;
ok ()
Ligo.Run.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value
in
let term =
Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax) in
Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ display_format) 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)
let compile_storage =
let f source entry_point expression syntax =
toplevel @@
let f source entry_point expression syntax display_format bigmap =
toplevel ~display_format @@
let%bind value =
trace (simple_error "compile-storage") @@
Ligo.Run.compile_contract_storage source entry_point expression (Syntax_name syntax) in
Format.printf "%s\n" value;
ok ()
Ligo.Run.Of_source.compile_file_contract_storage ~value:bigmap source entry_point expression (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value
in
let term =
Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax) in
Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ display_format $ bigmap) 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 amount syntax =
toplevel @@
let f source entry_point storage input amount syntax display_format bigmap =
toplevel ~display_format @@
let%bind output =
Ligo.Run.run_contract ~amount source entry_point storage input (Syntax_name syntax) in
Format.printf "%a\n" Ast_simplified.PP.expression output ;
ok ()
Ligo.Run.Of_source.run_contract ~amount ~storage_value:bigmap source entry_point storage input (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output
in
let term =
Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax) in
Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax $ display_format $ bigmap) 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 run_function =
let f source entry_point parameter amount syntax =
toplevel @@
let f source entry_point parameter amount syntax display_format =
toplevel ~display_format @@
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 ()
Ligo.Run.Of_source.run_function_entry ~amount source entry_point parameter (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output
in
let term =
Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax) in
Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax $ display_format) 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 f source entry_point amount syntax display_format =
toplevel ~display_format @@
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 ()
Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output
in
let term =
Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax) in
Term.(const f $ source 0 $ entry_point 1 $ amount $ syntax $ display_format) in
let cmdname = "evaluate-value" in
let docs = "Subcommand: evaluate a given definition." in
(term , Term.info ~docs cmdname)
let compile_expression =
let f expression syntax display_format =
toplevel ~display_format @@
let%bind value =
trace (simple_error "compile-input") @@
Ligo.Run.Of_source.compile_expression expression (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value
in
let term =
Term.(const f $ expression "" 0 $ syntax $ display_format) in
let cmdname = "compile-expression" in
let docs = "Subcommand: compile to a michelson value." in
(term , Term.info ~docs cmdname)
let () = Term.exit @@ Term.eval_choice main [
compile_file ;
compile_parameter ;
compile_storage ;
compile_expression ;
dry_run ;
run_function ;
evaluate_value ;

19
src/bin/cli_helpers.ml
View File

@ -1,9 +1,16 @@
open Trace
open Main.Display
let toplevel x =
let toplevel ~(display_format : string) (x : string result) =
let display_format =
try display_format_of_string display_format
with _ -> (
Format.printf "bad display format %s, try looking at DISPLAY_FORMAT in the man (--help)." display_format ;
failwith "Display format"
)
in
match x with
| Trace.Ok ((), annotations) -> ignore annotations; ()
| Error ss -> (
Format.printf "%a%!" Ligo.Display.error_pp (ss ())
)
| Ok _ -> Format.printf "%a\n%!" (formatted_string_result_pp display_format) x
| Error _ ->
Format.eprintf "%a\n%!" (formatted_string_result_pp display_format) x ;
exit 1

2
src/bin/dune
View File

@ -8,7 +8,7 @@
)
(package ligo)
(preprocess
(pps simple-utils.ppx_let_generalized)
(pps ppx_let)
)
(flags (:standard -open Simple_utils))
)

294
src/compiler/compiler_environment.ml
View File

@ -1,294 +0,0 @@
open Proto_alpha_utils
open Trace
open Mini_c
open Environment
open Michelson
open Memory_proto_alpha.Script_ir_translator
module Stack = Meta_michelson.Stack
let get : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) =
let error =
let title () = "Environment.get" in
let content () = Format.asprintf "%s in %a"
s PP.environment e in
error title content in
generic_try error @@
(fun () -> Environment.get_i s e) in
let rec aux = fun n ->
match n with
| 0 -> i_dup
| n -> seq [
dip @@ aux (n - 1) ;
i_swap ;
]
in
let code = aux position in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let output_stack_ty = Stack.(ty @: input_stack_ty) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let set : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) =
generic_try (simple_error "Environment.get") @@
(fun () -> Environment.get_i s e) in
let rec aux = fun n ->
match n with
| 0 -> dip i_drop
| n -> seq [
i_swap ;
dip (aux (n - 1)) ;
]
in
let code = aux position in
let%bind () =
let error () = ok @@ simple_error "error producing Env.set" in
let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: env_stack_ty) in
let output_stack_ty = env_stack_ty in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) ->
let code = seq [] in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: env_stack_ty) in
let output_stack_ty = Stack.(ty @: env_stack_ty) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
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 , 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 =
let aux = fun code (_ , b) ->
match b with
| false -> seq [dip code ; i_drop]
| true -> dip code
in
List.fold_right' aux (seq []) e_lst in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' =
Environment.of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in
let error () =
let title () = "error producing Env.select" in
let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
PP.environment e
PP.environment e'
PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
Michelson.pp code
(L.get ())
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let select_env : environment -> environment -> michelson result = fun source filter ->
let lst = Environment.get_names filter in
select source lst
let clear : environment -> (michelson * environment) result = fun e ->
let lst = Environment.get_names e in
let%bind first_name =
trace_option (simple_error "try to clear empty env") @@
List.nth_opt lst 0 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 ->
let%bind () =
trace_strong (simple_error "pack empty env") @@
Assert.assert_true (List.length e <> 0) in
let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let repr = Environment.closure_representation e in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ repr in
let output_stack_ty = Stack.(output_ty @: nil) in
let error () =
let title () = "error producing Env.pack" in
let content () = Format.asprintf ""
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let unpack : environment -> michelson result = fun e ->
let%bind () =
trace_strong (simple_error "unpack empty env") @@
Assert.assert_true (List.length e <> 0) in
let l = List.length e - 1 in
let rec aux n =
match n with
| 0 -> seq []
| n -> seq [
i_unpair ;
dip (aux (n - 1)) ;
] in
let code = aux l in
let%bind () =
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e in
let repr = Environment.closure_representation e in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ repr in
let input_stack_ty = Stack.(input_ty @: nil) in
let error () =
let title () = "error producing Env.unpack" in
let content () = Format.asprintf "\nEnvironment:%a\nType Representation:%a\nCode:%a\n"
PP.environment e
PP.type_ repr
Michelson.pp code
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let pack_select : 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
let e_lst'' = List.combine e_lst e_lst' in
e_lst'' in
let (_ , code) =
let aux = fun (first , code) (_ , b) ->
match b with
| false -> (first , seq [dip code ; i_swap])
| true -> (false ,
match first with
| true -> i_dup
| false -> seq [dip code ; i_dup ; dip i_pair ; i_swap]
)
in
List.fold_right' aux (true , seq []) e_lst in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' =
Environment.of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
let output_stack_ty = Stack.(output_ty @: input_stack_ty) in
let error () =
let title () = "error producing Env.pack_select" in
let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
PP.environment e
PP.environment e'
PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
Michelson.pp code
(L.get ())
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let add_packed_anon : environment -> type_value -> michelson result = fun e type_value ->
let code = seq [i_pair] in
let%bind () =
let error () = ok @@ simple_error "error producing add packed" in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in
let e' = Environment.add ("_add_packed_anon" , type_value) e in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: input_ty @: nil) in
let output_stack_ty = Stack.(output_ty @: nil) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let pop : environment -> environment result = fun e ->
match e with
| [] -> simple_fail "pop empty env"
| _ :: tl -> ok tl

558
src/compiler/compiler_program.ml
View File

@ -1,558 +0,0 @@
open Trace
open Mini_c
open Michelson
module Stack = Meta_michelson.Stack
module Contract_types = Meta_michelson.Types
open Memory_proto_alpha.Script_ir_translator
open Operators.Compiler
open Proto_alpha_utils
let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst ->
match Map.String.find_opt s Operators.Compiler.predicates with
| 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 ] ->
let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in
ok v
| _ -> simple_fail "mini_c . MAP_REMOVE" in
let%bind v_ty = Compiler_type.type_ v in
ok @@ simple_binary @@ seq [dip (i_none v_ty) ; prim I_UPDATE ]
| "LEFT" ->
let%bind r = match lst with
| [ _ ] -> get_t_right ty
| _ -> simple_fail "mini_c . LEFT" in
let%bind r_ty = Compiler_type.type_ r in
ok @@ simple_unary @@ prim ~children:[r_ty] I_LEFT
| "RIGHT" ->
let%bind l = match lst with
| [ _ ] -> get_t_left ty
| _ -> simple_fail "mini_c . RIGHT" in
let%bind l_ty = Compiler_type.type_ l in
ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT
| "CONTRACT" ->
let%bind r = match lst with
| [ _ ] -> get_t_contract ty
| _ -> simple_fail "mini_c . CONTRACT" in
let%bind r_ty = Compiler_type.type_ r in
ok @@ simple_unary @@ seq [
prim ~children:[r_ty] I_CONTRACT ;
i_assert_some_msg (i_push_string "bad address for get_contract") ;
]
| x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist")
)
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)
| D_unit -> ok @@ prim D_Unit
| D_pair (a, b) -> (
let%bind a = translate_value a in
let%bind b = translate_value b in
ok @@ prim ~children:[a;b] D_Pair
)
| D_left a -> translate_value a >>? fun a -> ok @@ prim ~children:[a] D_Left
| D_right b -> translate_value b >>? fun b -> ok @@ prim ~children:[b] D_Right
| D_function anon -> translate_function anon
| D_none -> ok @@ prim D_None
| D_some s ->
let%bind s' = translate_value s in
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 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"
and translate_function (content:anon_function) : michelson result =
let%bind body = translate_quote_body content in
ok @@ seq [ body ]
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 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 , 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
| 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\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
let%bind _ =
Trace.trace_tzresult_lwt_r
(fun () ->
let%bind error_message = error_message () in
ok @@ (fun () -> error (thunk "error parsing expression code")
(fun () -> error_message)
())) @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
ok (code , env')
in
trace (error (thunk "compiling expression") error_message) @@
match expr' with
| 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 ~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 ~end_env:load_env @@ seq [
expr' ;
dip clear ;
unpack ;
]
)
| E_environment_select sub_env ->
let%bind code = Compiler_environment.select_env env sub_env in
return ~end_env:sub_env @@ seq [
code ;
]
| E_environment_return expr -> (
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' ;
code ;
]
)
| E_literal v ->
let%bind v = translate_value v in
let%bind t = Compiler_type.type_ ty in
return @@ i_push t v
| E_application(f, arg) -> (
match Combinators.Expression.get_type f with
| T_function _ -> (
trace (simple_error "Compiling quote application") @@
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" ;
f ;
i_comment "get arg" ;
arg ;
prim I_EXEC ;
]
)
| T_deep_closure (small_env, input_ty , _) -> (
trace (simple_error "Compiling deep closure application") @@
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 =
let error_title () = "michelson type-checking closure application" in
let error_content () =
Format.asprintf "\nEnv. %a\nEnv'. %a\nEnv''. %a\nclosure. %a ; %a ; %a\narg. %a\n"
PP.environment env
PP.environment env'
PP.environment env''
PP.expression_with_type f Michelson.pp f_ty Michelson.pp f'
PP.expression_with_type arg
in
error error_title error_content
in
trace error @@
return @@ seq [
i_comment "closure application" ;
i_comment "arg" ;
arg' ;
i_comment "f'" ;
f' ; i_unpair ;
i_comment "append" ;
dip @@ seq [i_swap ; append_closure] ;
i_comment "exec" ;
i_swap ; i_exec ;
]
)
| _ -> simple_fail "E_applicationing something not appliable"
)
| E_variable x ->
let%bind code = Compiler_environment.get env x in
return code
| E_sequence (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' ;
b' ;
]
)
| E_constant(str, lst) ->
let module L = Logger.Stateful() in
let%bind lst' =
let aux env expr =
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
PP.environment env ;
ok (env' , code)
in
bind_fold_map_right_list aux env lst in
let%bind predicate = get_predicate str ty lst in
let pre_code = seq @@ List.rev lst' in
let%bind code = match (predicate, List.length lst) with
| Constant c, 0 -> ok @@ seq [
pre_code ;
c ;
]
| Unary f, 1 -> ok @@ seq [
pre_code ;
f ;
]
| Binary f, 2 -> ok @@ seq [
pre_code ;
f ;
]
| Ternary f, 3 -> ok @@ seq [
pre_code ;
f ;
]
| _ -> simple_fail "bad arity"
in
let error =
let title () = "error compiling constant" in
let content () = L.get () in
error title content in
trace error @@
return code
| E_make_empty_map sd ->
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
return @@ i_empty_map src dst
| E_make_empty_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 ~push_var_name:"bool_condition" c env in
let%bind popped = Compiler_environment.pop env' 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 ~end_env:env_a' code
)
| E_if_none (c, n, (ntv , s)) -> (
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 ~push_var_name:"if_none" n popped in
let s_env = Environment.add ntv popped 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 [
c' ;
i_if_none n' (seq [
s' ;
dip restrict_s ;
])
;
]) in
return code
)
| E_if_left (c, (l_ntv , l), (r_ntv , r)) -> (
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' , _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' , _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 [
c' ;
i_if_left (seq [
l' ;
i_comment "restrict left" ;
dip restrict_l ;
]) (seq [
r' ;
i_comment "restrict right" ;
dip restrict_r ;
])
;
]) in
return code
)
| E_let_in (v , expr , body) -> (
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 ~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
let%bind code = ok (seq [
expr' ;
body' ;
i_comment "restrict let" ;
dip restrict ;
]) 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 ~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
| `Left -> seq [dip i_unpair ; acc ; i_pair]
| `Right -> seq [dip i_unpiar ; acc ; i_piar]
in
let init = dip i_drop in
List.fold_right' aux init lrs
in
let%bind set_code = Compiler_environment.set env name in
let error =
let title () = "michelson type-checking patch" in
let content () =
let aux ppf = function
| `Left -> Format.fprintf ppf "left"
| `Right -> Format.fprintf ppf "right" in
Format.asprintf "Sub path: %a\n"
PP_helpers.(list_sep aux (const " , ")) lrs
in
error title content in
trace error @@
return ~end_env:env ~unit_opt:true @@ seq [
i_comment "assign: start # env" ;
expr' ;
i_comment "assign: compute rhs # rhs : env" ;
get_code ;
i_comment "assign: get name # name : rhs : env" ;
i_swap ;
i_comment "assign: swap # rhs : name : env" ;
modify_code ;
i_comment "assign: modify code # name+rhs : env" ;
set_code ;
i_comment "assign: set new # new_env" ;
]
)
| 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 ~end_env:env ~unit_opt:true @@ seq [
expr' ;
prim ~children:[seq [
block' ;
restrict_block ;
expr']] I_LOOP ;
]
)
and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result =
let env = Environment.(add (binder , input) empty) in
let%bind (expr , env') = translate_expression result env in
let code = seq [
i_comment "function result" ;
expr ;
] in
let%bind _assert_type =
let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in
let input_stack_ty = Stack.(input_ty @: nil) in
let output_stack_ty = Stack.(output_ty @: nil) in
let error_message () =
Format.asprintf
"\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 (
error (thunk "error parsing quote code") error_message
) @@
Proto_alpha_utils.Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
ok ()
in
ok code
type compiled_program = {
input : ex_ty ;
output : ex_ty ;
body : michelson ;
}
let get_main : program -> string -> anon_function result = fun p entry ->
let is_main (((name , expr), _):toplevel_statement) =
match Combinators.Expression.(get_content expr , get_type expr)with
| (E_literal (D_function content) , T_function _)
when name = entry ->
Some content
| _ -> None
in
let%bind main =
trace_option (simple_error "no functional entry") @@
List.find_map is_main p
in
ok main
let translate_program (p:program) (entry:string) : compiled_program result =
let%bind main = get_main p entry in
let {input;output} : anon_function = main in
let%bind body = translate_quote_body main in
let%bind input = Compiler_type.Ty.type_ input in
let%bind output = Compiler_type.Ty.type_ output in
ok ({input;output;body}:compiled_program)
let translate_entry (p:anon_function) : compiled_program result =
let {input;output} : anon_function = p in
let%bind body =
trace (simple_error "compile entry body") @@
translate_quote_body p in
let%bind input = Compiler_type.Ty.type_ input in
let%bind output = Compiler_type.Ty.type_ output in
ok ({input;output;body}:compiled_program)
module Errors = struct
let corner_case ~loc message =
let title () = "corner case" in
let content () = "we don't have a good error message for this case. we are
striving find ways to better report them and find the use-cases that generate
them. please report this to the developers." in
let data = [
("location" , fun () -> loc) ;
("message" , fun () -> message) ;
] in
error ~data title content
end
open Errors
let translate_contract : anon_function -> michelson result = fun f ->
let%bind compiled_program =
trace_strong (corner_case ~loc:__LOC__ "compiling") @@
translate_entry f in
let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input in
let%bind param_michelson = Compiler_type.type_ param_ty in
let%bind storage_michelson = Compiler_type.type_ storage_ty in
let contract = Michelson.contract param_michelson storage_michelson compiled_program.body in
ok contract

5
src/contracts/annotation.ligo
View File

@ -1,5 +0,0 @@
const lst : list(int) = list [] ;
const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ;
const address_2 : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ;

1
src/contracts/error_type.ligo
View File

@ -1 +0,0 @@
const foo : nat = 42 + "bar"

11
src/contracts/for_fail.ligo Normal file
View File

@ -0,0 +1,11 @@
// This was meant to test the for loop in PascaLIGO
// But for whatever reason, the LIGO compiler currently thinks this is a 'complex loop'
// even though it isn't.
// See this error:
// $ ligo dry-run for.ligo main 0 0
// bounded iterators: only simple for loops are supported yet
// {"loop_loc":"in file \"for.ligo\", line 4, characters 10-42"}
function main (const a: int) : int is
block { for i := 0 to 100 block { skip } } with i;

1
src/contracts/included.ligo
View File

@ -1 +0,0 @@
const foo : int = 144

3
src/contracts/includer.ligo
View File

@ -1,3 +0,0 @@
#include "included.ligo"
const bar : int = foo

10
src/contracts/list.mligo
View File

@ -1,10 +0,0 @@
type storage = int * int list
type param = int list
let%entry main (p : param) storage =
let storage =
match p with
[] -> storage
| hd::tl -> storage.(0) + hd, tl
in (([] : operation list), storage)

11
src/contracts/procedure.ligo Normal file
View File

@ -0,0 +1,11 @@
// Test a trivial PascaLIGO procedure
procedure sub (const j: int) is
begin
i := i + 1
end
function main (const i: int) : int is
begin
sub(i)
end with i

20
src/dune
View File

@ -6,27 +6,9 @@
simple-utils
tezos-utils
tezos-micheline
meta_michelson
main
)
(preprocess
(pps simple-utils.ppx_let_generalized)
(pps ppx_let)
)
)
(alias
(name ligo-test)
(action (run test/test.exe))
(deps (glob_files contracts/*))
)
(alias
(name runtest)
(deps (alias ligo-test))
)
(alias
(name manual-test)
(action (run test/manual_test.exe))
(deps (glob_files contracts/*))
)

2
src/dune-project
View File

@ -1,2 +0,0 @@
(lang dune 1.6)
(using menhir 2.0)

22
src/main/compile/dune Normal file
View File

@ -0,0 +1,22 @@
(library
(name compile)
(public_name ligo.compile)
(libraries
simple-utils
tezos-utils
parser
simplify
ast_simplified
self_ast_simplified
typer
ast_typed
transpiler
mini_c
compiler
self_michelson
)
(preprocess
(pps ppx_let)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
)

76
src/main/compile/helpers.ml Normal file
View File

@ -0,0 +1,76 @@
open Trace
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
let (Syntax_name syntax) = syntax in
match (syntax , source_filename) with
| "auto" , Some sf when endswith sf ".ligo" -> ok Pascaligo
| "auto" , Some sf when endswith sf ".mligo" -> ok Cameligo
| "auto" , _ -> simple_fail "cannot auto-detect syntax, pleas use -s name_of_syntax"
| "pascaligo" , _ -> ok Pascaligo
| "cameligo" , _ -> ok Cameligo
| _ -> simple_fail "unrecognized parser"
let parsify_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Pascaligo.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Pascaligo.simpl_program raw in
ok simplified
let parsify_expression_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Pascaligo.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Pascaligo.simpl_expression raw in
ok simplified
let parsify_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Ligodity.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Ligodity.simpl_program raw in
ok simplified
let parsify_expression_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Ligodity.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Ligodity.simpl_expression raw in
ok simplified
let parsify = fun (syntax : v_syntax) source_filename ->
let%bind parsify = match syntax with
| Pascaligo -> ok parsify_pascaligo
| Cameligo -> ok parsify_ligodity
in
let%bind parsified = parsify source_filename in
let%bind applied = Self_ast_simplified.all_program parsified in
ok applied
let parsify_expression = fun syntax source ->
let%bind parsify = match syntax with
| Pascaligo -> ok parsify_expression_pascaligo
| Cameligo -> ok parsify_expression_ligodity
in
let%bind parsified = parsify source in
let%bind applied = Self_ast_simplified.all_expression parsified in
ok applied

56
src/main/compile/of_mini_c.ml Normal file
View File

@ -0,0 +1,56 @@
open Trace
open Mini_c
open Tezos_utils
let compile_value : value -> type_value -> Michelson.t result = fun x a ->
let%bind body = Compiler.Program.translate_value x a in
let body = Self_michelson.optimize body in
ok body
let compile_expression_as_value : expression -> _ result = fun e ->
let%bind value = expression_to_value e in
let%bind result = compile_value value e.type_value in
let result = Self_michelson.optimize result in
ok result
let compile_expression_as_function : expression -> _ result = fun e ->
let (input , output) = t_unit , e.type_value in
let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in
let body = Self_michelson.optimize body in
let body = Michelson.(seq [ i_drop ; body ]) in
let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
let open! Compiler.Program in
ok { input ; output ; body }
let compile_function = fun e ->
let%bind (input , output) = get_t_function e.type_value in
let%bind body = get_function e in
let%bind body = compile_value body (t_function input output) in
let body = Self_michelson.optimize body in
let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
let open! Compiler.Program in
ok { input ; output ; body }
let compile_expression_as_function_entry = fun program name ->
let%bind aggregated = aggregate_entry program name true in
compile_function aggregated
let compile_function_entry = fun program name ->
let%bind aggregated = aggregate_entry program name false in
compile_function aggregated
let compile_contract_entry = fun program name ->
let%bind aggregated = aggregate_entry program name false in
let%bind compiled = compile_function aggregated in
let%bind (param_ty , storage_ty) =
let%bind fun_ty = get_t_function aggregated.type_value in
Mini_c.get_t_pair (fst fun_ty)
in
let%bind param_michelson = Compiler.Type.type_ param_ty in
let%bind storage_michelson = Compiler.Type.type_ storage_ty in
let contract = Michelson.contract param_michelson storage_michelson compiled.body in
ok contract
let uncompile_value : Proto_alpha_utils.Memory_proto_alpha.X.ex_typed_value -> value result = fun x ->
Compiler.Uncompiler.translate_value x

40
src/main/compile/of_simplified.ml Normal file
View File

@ -0,0 +1,40 @@
open Ast_simplified
open Trace
open Tezos_utils
let compile_contract_entry (program : program) entry_point =
let%bind prog_typed = Typer.type_program program in
Of_typed.compile_contract_entry prog_typed entry_point
let compile_function_entry (program : program) entry_point : _ result =
let%bind prog_typed = Typer.type_program program in
Of_typed.compile_function_entry prog_typed entry_point
let compile_expression_as_function_entry (program : program) entry_point : _ result =
let%bind typed_program = Typer.type_program program in
Of_typed.compile_expression_as_function_entry typed_program entry_point
let compile_expression_as_value ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result =
let%bind typed = Typer.type_expression env ae in
Of_typed.compile_expression_as_value typed
let compile_expression_as_function ?(env = Ast_typed.Environment.full_empty) ae : _ result =
let%bind typed = Typer.type_expression env ae in
Of_typed.compile_expression_as_function typed
let uncompile_typed_program_entry_expression_result program entry ex_ty_value =
let%bind output_type =
let%bind entry_expression = Ast_typed.get_entry program entry in
ok entry_expression.type_annotation
in
let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in
Typer.untype_expression typed
let uncompile_typed_program_entry_function_result program entry ex_ty_value =
let%bind output_type =
let%bind entry_expression = Ast_typed.get_entry program entry in
let%bind (_ , output_type) = Ast_typed.get_t_function entry_expression.type_annotation in
ok output_type
in
let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in
Typer.untype_expression typed

39
src/main/compile/of_source.ml Normal file
View File

@ -0,0 +1,39 @@
open Trace
open Helpers
let parse_file_program source_filename syntax =
let%bind syntax = syntax_to_variant syntax (Some source_filename) in
let%bind simplified = parsify syntax source_filename in
ok simplified
let compile_file_entry : string -> string -> s_syntax -> _ result =
fun source_filename entry_point syntax ->
let%bind simplified = parse_file_program source_filename syntax in
Of_simplified.compile_function_entry simplified entry_point
let compile_file_contract_entry : string -> string -> s_syntax -> _ result =
fun source_filename entry_point syntax ->
let%bind simplified = parse_file_program source_filename syntax in
let%bind compiled_contract = Of_simplified.compile_contract_entry simplified entry_point in
ok compiled_contract
let compile_expression_as_function : string -> s_syntax -> _ result =
fun expression syntax ->
let%bind syntax = syntax_to_variant syntax None in
let%bind simplified = parsify_expression syntax expression in
Of_simplified.compile_expression_as_function simplified
let type_file ?(debug_simplify = false) ?(debug_typed = false)
syntax (source_filename:string) : Ast_typed.program result =
let%bind syntax = syntax_to_variant syntax (Some source_filename) in
let%bind simpl = parsify syntax source_filename in
(if debug_simplify then
Format.(printf "Simplified : %a\n%!" Ast_simplified.PP.program simpl)
) ;
let%bind typed =
trace (simple_error "typing") @@
Typer.type_program simpl in
(if debug_typed then (
Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed)
)) ;
ok typed

57
src/main/compile/of_typed.ml Normal file
View File

@ -0,0 +1,57 @@
open Trace
open Ast_typed
open Tezos_utils
let compile_expression_as_value : annotated_expression -> Michelson.t result = fun e ->
let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
let%bind expr = Of_mini_c.compile_expression_as_value mini_c_expression in
ok expr
let compile_expression_as_function : annotated_expression -> _ result = fun e ->
let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
let%bind expr = Of_mini_c.compile_expression_as_function mini_c_expression in
ok expr
let compile_function : annotated_expression -> _ result = fun e ->
let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
let%bind expr = Of_mini_c.compile_function mini_c_expression in
ok expr
(*
val compile_value : annotated_expression -> Michelson.t result
This requires writing a function
`transpile_expression_as_value : annotated_expression -> Mini_c.value result`
*)
let compile_function_entry : program -> string -> _ = fun p entry ->
let%bind prog_mini_c = Transpiler.transpile_program p in
Of_mini_c.compile_function_entry prog_mini_c entry
let compile_contract_entry : program -> string -> _ = fun p entry ->
let%bind prog_mini_c = Transpiler.transpile_program p in
Of_mini_c.compile_contract_entry prog_mini_c entry
let compile_expression_as_function_entry : program -> string -> _ = fun p entry ->
let%bind prog_mini_c = Transpiler.transpile_program p in
Of_mini_c.compile_expression_as_function_entry prog_mini_c entry
let uncompile_value : _ -> _ -> annotated_expression result = fun x ty ->
let%bind mini_c = Of_mini_c.uncompile_value x in
let%bind typed = Transpiler.untranspile mini_c ty in
ok typed
let uncompile_entry_function_result = fun program entry ex_ty_value ->
let%bind output_type =
let%bind entry_expression = get_entry program entry in
let%bind (_ , output_type) = get_t_function entry_expression.type_annotation in
ok output_type
in
uncompile_value ex_ty_value output_type
let uncompile_entry_expression_result = fun program entry ex_ty_value ->
let%bind output_type =
let%bind entry_expression = get_entry program entry in
ok entry_expression.type_annotation
in
uncompile_value ex_ty_value output_type

82
src/main/display.ml
View File

@ -1,6 +1,6 @@
open Trace
open! Trace
let error_pp out (e : error) =
let rec error_pp ?(dev = false) out (e : error) =
let open JSON_string_utils in
let message =
let opt = e |> member "message" |> string in
@ -26,6 +26,12 @@ let error_pp out (e : error) =
| `List lst -> lst
| `Null -> []
| x -> [ x ] in
let children =
let infos = e |> member "children" 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 =
@ -38,5 +44,73 @@ let error_pp out (e : error) =
| 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 *)
if not dev then (
print "%s%s%s%s%s" location title error_code message data
) else (
print "%s%s%s.\n%s%s\n%a\n%a\n" title error_code message data location
(Format.pp_print_list (error_pp ~dev)) infos
(Format.pp_print_list (error_pp ~dev)) children
)
let result_pp_hr f out (r : _ result) =
match r with
| Ok (s , _) -> Format.fprintf out "%a" f s
| Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ())
let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s" s)
let result_pp_dev f out (r : _ result) =
match r with
| Ok (s , _) -> Format.fprintf out "%a" f s
| Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ())
let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s" s)
let json_pp out x = Format.fprintf out "%s" (J.to_string x)
let string_result_pp_json out (r : string result) =
let status_json status content : J.t = `Assoc ([
("status" , `String status) ;
("content" , content) ;
]) in
match r with
| Ok (x , _) -> (
Format.fprintf out "%a" json_pp (status_json "ok" (`String x))
)
| Error e -> (
Format.fprintf out "%a" json_pp (status_json "error" (e ()))
)
type display_format = [
| `Human_readable
| `Json
| `Dev
]
let display_format_of_string = fun s : display_format ->
match s with
| "dev" -> `Dev
| "json" -> `Json
| "human-readable" -> `Human_readable
| _ -> failwith "bad display_format"
let formatted_string_result_pp (display_format : display_format) =
match display_format with
| `Human_readable -> string_result_pp_hr
| `Dev -> string_result_pp_dev
| `Json -> string_result_pp_json
type michelson_format = [
| `Michelson
| `Micheline
]
let michelson_format_of_string = fun s : michelson_format result ->
match s with
| "michelson" -> ok `Michelson
| "micheline" -> ok `Micheline
| _ -> simple_fail "bad michelson format"
let michelson_pp (mf : michelson_format) = match mf with
| `Michelson -> Michelson.pp
| `Micheline -> Michelson.pp_json

15
src/main/dune
View File

@ -2,20 +2,11 @@
(name main)
(public_name ligo.main)
(libraries
simple-utils
tezos-utils
parser
simplify
ast_simplified
typer
ast_typed
transpiler
mini_c
operators
compiler
run
compile
)
(preprocess
(pps simple-utils.ppx_let_generalized)
(pps ppx_let)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
)

138
src/main/main.ml
View File

@ -1,137 +1,3 @@
module Run_mini_c = Run_mini_c
(* open Trace *)
module Parser = Parser
module AST_Raw = Parser.Pascaligo.AST
module AST_Simplified = Ast_simplified
module AST_Typed = Ast_typed
module Mini_c = Mini_c
module Typer = Typer
module Transpiler = Transpiler
module Run = struct
include Run_source
include Run_simplified
include Run_typed
include Run_mini_c
end
module Run = Run
module Compile = Compile
module Display = Display
(* module Parser_multifix = Multifix
* module Simplify_multifix = Simplify_multifix *)
(* let simplify (p:AST_Raw.t) : Ast_simplified.program result = Simplify.Pascaligo.simpl_program p
* let simplify_expr (e:AST_Raw.expr) : Ast_simplified.expression result = Simplify.Pascaligo.simpl_expression e
* let unparse_simplified_expr (e:AST_Simplified.expression) : string result =
* ok @@ Format.asprintf "%a" AST_Simplified.PP.expression e
*
* let type_ (p:AST_Simplified.program) : AST_Typed.program result = Typer.type_program p
* let type_expression ?(env:Typer.Environment.t = Typer.Environment.full_empty)
* (e:AST_Simplified.expression) : AST_Typed.annotated_expression result =
* Typer.type_expression env e
* let untype_expression (e:AST_Typed.annotated_expression) : AST_Simplified.expression result = Typer.untype_expression e
*
* let transpile (p:AST_Typed.program) : Mini_c.program result = Transpiler.translate_program p
* let transpile_entry (p:AST_Typed.program) (name:string) : Mini_c.anon_function result = Transpiler.translate_entry p name
* let transpile_expression (e:AST_Typed.annotated_expression) : Mini_c.expression result = Transpiler.translate_annotated_expression e
*
* let untranspile_value (v : Mini_c.value) (e:AST_Typed.type_value) : AST_Typed.annotated_expression result =
* Transpiler.untranspile v e
*
* let compile : Mini_c.program -> string -> Compiler.Program.compiled_program result = Compiler.Program.translate_program
*
* let easy_evaluate_typed (entry:string) (program:AST_Typed.program) : AST_Typed.annotated_expression result =
* let%bind result =
* let%bind mini_c_main =
* transpile_entry program entry in
* Run_mini_c.run_entry mini_c_main (Mini_c.Combinators.d_unit) in
* let%bind typed_result =
* let%bind typed_main = Ast_typed.get_entry program entry in
* untranspile_value result typed_main.type_annotation in
* ok typed_result
*
*
* let easy_evaluate_typed = trace_f_2_ez easy_evaluate_typed (thunk "easy evaluate typed")
*
*
* let easy_run_typed
* ?(debug_mini_c = false) ?options (entry:string)
* (program:AST_Typed.program) (input:AST_Typed.annotated_expression) : AST_Typed.annotated_expression result =
* let%bind () =
* let open Ast_typed in
* let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
* let%bind (arg_ty , _) =
* trace_strong (simple_error "entry-point doesn't have a function type") @@
* get_t_function @@ get_type_annotation d.annotated_expression in
* Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
* in
*
* let%bind mini_c_main =
* trace (simple_error "transpile mini_c entry") @@
* transpile_entry program entry in
* (if debug_mini_c then
* Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
* ) ;
*
* let%bind mini_c_value = transpile_value input in
*
* let%bind mini_c_result =
* let error =
* let title () = "run Mini_c" in
* let content () =
* Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
* in
* error title content in
* trace error @@
* Run_mini_c.run_entry ?options mini_c_main mini_c_value in
* let%bind typed_result =
* let%bind main_result_type =
* let%bind typed_main = Ast_typed.get_functional_entry program entry in
* match (snd typed_main).type_value' with
* | T_function (_, result) -> ok result
* | _ -> simple_fail "main doesn't have fun type" in
* untranspile_value mini_c_result main_result_type in
* ok typed_result
*
* let easy_run_typed_simplified
* ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
* (program:AST_Typed.program) (input:Ast_simplified.expression) : Ast_simplified.expression result =
* let%bind mini_c_main =
* trace (simple_error "transpile mini_c entry") @@
* transpile_entry program entry in
* (if debug_mini_c then
* Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
* ) ;
*
* let%bind typed_value =
* let env =
* let last_declaration = Location.unwrap List.(hd @@ rev program) in
* match last_declaration with
* | Declaration_constant (_ , (_ , post_env)) -> post_env
* in
* type_expression ~env input in
* let%bind mini_c_value = transpile_value typed_value in
*
* let%bind mini_c_result =
* let error =
* let title () = "run Mini_c" in
* let content () =
* Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
* in
* error title content in
* trace error @@
* Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
* let%bind typed_result =
* let%bind main_result_type =
* let%bind typed_main = Ast_typed.get_functional_entry program entry in
* match (snd typed_main).type_value' with
* | T_function (_, result) -> ok result
* | _ -> simple_fail "main doesn't have fun type" in
* untranspile_value mini_c_result main_result_type in
* let%bind annotated_result = untype_expression typed_result in
* ok annotated_result *)
(* module Contract = Contract *)

22
src/main/run/dune Normal file
View File

@ -0,0 +1,22 @@
(library
(name run)
(public_name ligo.run)
(libraries
simple-utils
tezos-utils
parser
simplify
ast_simplified
typer
ast_typed
transpiler
mini_c
operators
compiler
compile
)
(preprocess
(pps ppx_let)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
)

47
src/main/run/of_michelson.ml Normal file
View File

@ -0,0 +1,47 @@
open Proto_alpha_utils
open Trace
open Compiler.Program
open Memory_proto_alpha.Protocol.Script_ir_translator
open Memory_proto_alpha.X
type options = Memory_proto_alpha.options
let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result =
let Compiler.Program.{input;output;body} : compiled_program = program in
let (Ex_ty input_ty) = input in
let (Ex_ty output_ty) = output in
(* let%bind input_ty_mich =
* Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@
* Memory_proto_alpha.unparse_michelson_ty input_ty in
* let%bind output_ty_mich =
* Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@
* Memory_proto_alpha.unparse_michelson_ty output_ty in
* Format.printf "code: %a\n" Michelson.pp program.body ;
* Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ;
* Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ;
* Format.printf "input: %a\n" Michelson.pp input_michelson ; *)
let%bind input =
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
Memory_proto_alpha.parse_michelson_data input_michelson input_ty
in
let body = Michelson.(strip_nops @@ strip_annots body) in
let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Memory_proto_alpha.parse_michelson body
(Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in
let open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind (Item(output, Empty)) =
Trace.trace_tzresult_lwt (simple_error "error of execution") @@
Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
ok (Ex_typed_value (output_ty, output))
let evaluate ?options program = run ?options program Michelson.d_unit
let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result =
let (Ex_typed_value (value , ty)) = v in
Trace.trace_tzresult_lwt (simple_error "error unparsing michelson result") @@
Memory_proto_alpha.unparse_michelson_data value ty
let evaluate_michelson ?options program =
let%bind etv = evaluate ?options program in
ex_value_ty_to_michelson etv

53
src/main/run/of_mini_c.ml Normal file
View File

@ -0,0 +1,53 @@
open Proto_alpha_utils
open Memory_proto_alpha.X
open Trace
open Mini_c
open! Compiler.Program
module Errors = struct
let entry_error =
simple_error "error translating entry point"
end
type options = {
entry_point : anon_function ;
input_type : type_value ;
output_type : type_value ;
input : value ;
michelson_options : Of_michelson.options ;
}
let evaluate ?options expression =
let%bind code = Compile.Of_mini_c.compile_expression_as_function expression in
let%bind ex_ty_value = Of_michelson.evaluate ?options code in
Compile.Of_mini_c.uncompile_value ex_ty_value
let evaluate_entry ?options program entry =
let%bind code = Compile.Of_mini_c.compile_expression_as_function_entry program entry in
let%bind ex_ty_value = Of_michelson.evaluate ?options code in
Compile.Of_mini_c.uncompile_value ex_ty_value
let run_function ?options expression input ty =
let%bind code = Compile.Of_mini_c.compile_function expression in
let%bind input = Compile.Of_mini_c.compile_value input ty in
let%bind ex_ty_value = Of_michelson.run ?options code input in
Compile.Of_mini_c.uncompile_value ex_ty_value
let run_function_value ?options expression input ty =
let%bind code = Compile.Of_mini_c.compile_function expression in
let%bind input = Compile.Of_mini_c.compile_value input ty in
let%bind ex_ty_value = Of_michelson.run ?options code input in
Compile.Of_mini_c.uncompile_value ex_ty_value
let run_function_entry ?options program entry input =
let%bind code = Compile.Of_mini_c.compile_function_entry program entry in
let%bind input_michelson =
let%bind code = Compile.Of_mini_c.compile_expression_as_function input in
let%bind (Ex_typed_value (ty , value)) = Of_michelson.evaluate ?options code in
Trace.trace_tzresult_lwt (simple_error "error unparsing input") @@
Memory_proto_alpha.unparse_michelson_data ty value
in
let%bind ex_ty_value = Of_michelson.run ?options code input_michelson in
Compile.Of_mini_c.uncompile_value ex_ty_value

32
src/main/run/of_simplified.ml Normal file
View File

@ -0,0 +1,32 @@
open Trace
open Ast_simplified
let compile_expression ?(value = false) ?env expr =
if value
then (
Compile.Of_simplified.compile_expression_as_value ?env expr
)
else (
let%bind code = Compile.Of_simplified.compile_expression_as_function ?env expr in
Of_michelson.evaluate_michelson code
)
let run_typed_program
?options ?input_to_value
(program : Ast_typed.program) (entry : string)
(input : expression) : expression result =
let%bind code = Compile.Of_typed.compile_function_entry program entry in
let%bind input =
let env = Ast_typed.program_environment program in
compile_expression ?value:input_to_value ~env input
in
let%bind ex_ty_value = Of_michelson.run ?options code input in
Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value
let evaluate_typed_program_entry
?options
(program : Ast_typed.program) (entry : string)
: Ast_simplified.expression result =
let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in
let%bind ex_ty_value = Of_michelson.evaluate ?options code in
Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value

137
src/main/run/of_source.ml Normal file
View File

@ -0,0 +1,137 @@
open Trace
include struct
open Ast_simplified
let assert_entry_point_defined : program -> string -> unit result =
fun program entry_point ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_type _ -> false
| Declaration_constant (name , _ , _) -> name = entry_point
in
trace_strong (simple_error "no entry-point with given name") @@
Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program
end
include struct
open Ast_typed
open Combinators
let get_entry_point_type : type_value -> (type_value * type_value) result = fun t ->
let%bind (arg , result) =
trace_strong (simple_error "entry-point doesn't have a function type") @@
get_t_function t in
let%bind (arg' , storage_param) =
trace_strong (simple_error "entry-point doesn't have 2 parameters") @@
get_t_pair arg in
let%bind (ops , storage_result) =
trace_strong (simple_error "entry-point doesn't have 2 results") @@
get_t_pair result in
let%bind () =
trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@
assert_t_list_operation ops in
let%bind () =
trace_strong (simple_error "entry-point doesn't identical type (storage) for second parameter and second result") @@
assert_type_value_eq (storage_param , storage_result) in
ok (arg' , storage_param)
let get_entry_point : program -> string -> (type_value * type_value) result = fun p e ->
let%bind declaration = get_declaration_by_name p e in
match declaration with
| Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation
let assert_valid_entry_point = fun p e ->
let%bind _ = get_entry_point p e in
ok ()
end
(* open Tezos_utils *)
let compile_file_contract_parameter : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result =
fun source_filename _entry_point expression syntax ->
let%bind program = Compile.Of_source.type_file syntax source_filename in
let env = Ast_typed.program_environment program in
let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in
let%bind simplified = Compile.Helpers.parsify_expression syntax expression in
Of_simplified.compile_expression simplified ~env
let compile_file_expression : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result =
fun source_filename _entry_point expression syntax ->
let%bind program = Compile.Of_source.type_file syntax source_filename in
let env = Ast_typed.program_environment program in
let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in
let%bind simplified = Compile.Helpers.parsify_expression syntax expression in
Of_simplified.compile_expression simplified ~env
let compile_expression : string -> Compile.Helpers.s_syntax -> Michelson.t result =
fun expression syntax ->
let%bind syntax = Compile.Helpers.syntax_to_variant syntax None in
let%bind simplified = Compile.Helpers.parsify_expression syntax expression in
Of_simplified.compile_expression simplified
let compile_file_contract_storage ~value : string -> string -> string -> Compile.Helpers.s_syntax -> Michelson.t result =
fun source_filename _entry_point expression syntax ->
let%bind program = Compile.Of_source.type_file syntax source_filename in
let env = Ast_typed.program_environment program in
let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in
let%bind simplified = Compile.Helpers.parsify_expression syntax expression in
Of_simplified.compile_expression ~value simplified ~env
let compile_file_contract_args =
fun ?value source_filename _entry_point storage parameter syntax ->
let%bind program = Compile.Of_source.type_file syntax source_filename in
let env = Ast_typed.program_environment program in
let%bind syntax = Compile.Helpers.syntax_to_variant syntax (Some source_filename) in
let%bind storage_simplified = Compile.Helpers.parsify_expression syntax storage in
let%bind parameter_simplified = Compile.Helpers.parsify_expression syntax parameter in
let args = Ast_simplified.e_pair storage_simplified parameter_simplified in
Of_simplified.compile_expression ?value args ~env
let run_contract ?amount ?storage_value source_filename entry_point storage parameter syntax =
let%bind program = Compile.Of_source.type_file syntax source_filename in
let%bind code = Compile.Of_typed.compile_function_entry program entry_point in
let%bind args = compile_file_contract_args ?value:storage_value source_filename entry_point storage parameter syntax in
let%bind ex_value_ty =
let options =
let open Proto_alpha_utils.Memory_proto_alpha in
let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
(make_options ?amount ())
in
Of_michelson.run ~options code args
in
Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty
let run_function_entry ?amount source_filename entry_point input syntax =
let%bind program = Compile.Of_source.type_file syntax source_filename in
let%bind code = Compile.Of_typed.compile_function_entry program entry_point in
let%bind args = compile_file_expression source_filename entry_point input syntax in
let%bind ex_value_ty =
let options =
let open Proto_alpha_utils.Memory_proto_alpha in
let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
(make_options ?amount ())
in
Of_michelson.run ~options code args
in
Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry_point ex_value_ty
let evaluate_entry ?amount source_filename entry_point syntax =
let%bind program = Compile.Of_source.type_file syntax source_filename in
let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry_point in
let%bind ex_value_ty =
let options =
let open Proto_alpha_utils.Memory_proto_alpha in
let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
(make_options ?amount ())
in
Of_michelson.evaluate ~options code
in
Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry_point ex_value_ty
let evaluate_michelson expression syntax =
let%bind code = Compile.Of_source.compile_expression_as_function expression syntax in
Of_michelson.evaluate_michelson code

42
src/main/run/of_typed.ml Normal file
View File

@ -0,0 +1,42 @@
open Trace
open Ast_typed
let compile_expression ?(value = false) expr =
if value
then (
Compile.Of_typed.compile_expression_as_value expr
)
else (
let%bind code = Compile.Of_typed.compile_expression_as_function expr in
Of_michelson.evaluate_michelson code
)
let run_function ?options f input =
let%bind code = Compile.Of_typed.compile_function f in
let%bind input = compile_expression input in
let%bind ex_ty_value = Of_michelson.run ?options code input in
let%bind ty =
let%bind (_ , output_ty) = get_t_function f.type_annotation in
ok output_ty
in
Compile.Of_typed.uncompile_value ex_ty_value ty
let run_entry
?options (entry : string)
(program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result =
let%bind code = Compile.Of_typed.compile_function_entry program entry in
let%bind input =
compile_expression input
in
let%bind ex_ty_value = Of_michelson.run ?options code input in
Compile.Of_typed.uncompile_entry_function_result program entry ex_ty_value
let evaluate ?options (e : annotated_expression) : annotated_expression result =
let%bind code = Compile.Of_typed.compile_expression_as_function e in
let%bind ex_ty_value = Of_michelson.evaluate ?options code in
Compile.Of_typed.uncompile_value ex_ty_value e.type_annotation
let evaluate_entry ?options program entry =
let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in
let%bind ex_ty_value = Of_michelson.evaluate ?options code in
Compile.Of_typed.uncompile_entry_expression_result program entry ex_ty_value

5
src/main/run/run.ml Normal file
View File

@ -0,0 +1,5 @@
module Of_source = Of_source
module Of_typed = Of_typed
module Of_simplified = Of_simplified
module Of_mini_c = Of_mini_c
module Of_michelson = Of_michelson

54
src/main/run_mini_c.ml
View File

@ -1,54 +0,0 @@
open Proto_alpha_utils
open Trace
open Mini_c
open! Compiler.Program
open Memory_proto_alpha.Script_ir_translator
let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result =
let Compiler.Program.{input;output;body} : compiled_program = program in
let (Ex_ty input_ty) = input in
let (Ex_ty output_ty) = output in
let%bind input =
Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
Memory_proto_alpha.parse_michelson_data input_michelson input_ty in
let body = Michelson.strip_annots body in
let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Memory_proto_alpha.parse_michelson body
(Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in
let open! Memory_proto_alpha.Script_interpreter in
let%bind (Item(output, Empty)) =
Trace.trace_tzresult_lwt (simple_error "error of execution") @@
Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
ok (Ex_typed_value (output_ty, output))
let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result =
let%bind compiled =
let error =
let title () = "compile entry" in
let content () =
Format.asprintf "%a" PP.function_ entry
in
error title content in
trace error @@
translate_entry entry in
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

27
src/main/run_simplified.ml
View File

@ -1,27 +0,0 @@
open Trace
let run_simplityped
?options
?(debug_mini_c = false) ?(debug_michelson = false)
(program : Ast_typed.program) (entry : string)
(input : Ast_simplified.expression) : Ast_simplified.expression result =
let%bind typed_input =
let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
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
?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 ?options ~debug_mini_c ~debug_michelson entry program in
let%bind annotated_result = Typer.untype_expression typed_result in
ok annotated_result

286
src/main/run_source.ml
View File

@ -1,286 +0,0 @@
open Trace
include struct
open Ast_simplified
let assert_entry_point_defined : program -> string -> unit result =
fun program entry_point ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_type _ -> false
| Declaration_constant (name , _ , _) -> name = entry_point
in
trace_strong (simple_error "no entry-point with given name") @@
Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program
end
include struct
open Ast_typed
open Combinators
let get_entry_point_type : type_value -> (type_value * type_value) result = fun t ->
let%bind (arg , result) =
trace_strong (simple_error "entry-point doesn't have a function type") @@
get_t_function t in
let%bind (arg' , storage_param) =
trace_strong (simple_error "entry-point doesn't have 2 parameters") @@
get_t_pair arg in
let%bind (ops , storage_result) =
trace_strong (simple_error "entry-point doesn't have 2 results") @@
get_t_pair result in
let%bind () =
trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@
assert_t_list_operation ops in
let%bind () =
trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@
assert_type_value_eq (storage_param , storage_result) in
ok (arg' , storage_param)
let get_entry_point : program -> string -> (type_value * type_value) result = fun p e ->
let%bind declaration = get_declaration_by_name p e in
match declaration with
| Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation
let assert_valid_entry_point = fun p e ->
let%bind _ = get_entry_point p e in
ok ()
end
let transpile_value
(e:Ast_typed.annotated_expression) : Mini_c.value result =
let%bind f =
let open Transpiler in
let (f , _) = functionalize e in
let%bind main = translate_main f e.location in
ok main
in
let input = Mini_c.Combinators.d_unit in
let%bind r = Run_mini_c.run_entry f input in
ok r
let parsify_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Pascaligo.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Pascaligo.simpl_program raw in
ok simplified
let parsify_expression_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Pascaligo.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Pascaligo.simpl_expression raw in
ok simplified
let parsify_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Ligodity.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Ligodity.simpl_program raw in
ok simplified
let parsify_expression_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Ligodity.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Ligodity.simpl_expression raw in
ok simplified
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
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
in
parsify source
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 =
trace (simple_error "typing") @@
Typer.type_program simplified in
let%bind mini_c =
trace (simple_error "transpiling") @@
Transpiler.translate_entry typed entry_point in
let%bind michelson =
trace (simple_error "compiling") @@
Compiler.translate_contract mini_c in
let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str
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_filename in
let%bind () =
assert_entry_point_defined simplified entry_point in
let%bind typed =
trace (simple_error "typing file") @@
Typer.type_program simplified in
let%bind (param_ty , _) =
get_entry_point typed entry_point in
ok (typed , param_ty)
in
let%bind expr =
let%bind typed =
let%bind simplified = parsify_expression syntax expression in
let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
in
trace (simple_error "typing expression") @@
Typer.type_expression env simplified in
let%bind () =
trace (simple_error "expression type doesn't match type parameter") @@
Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in
let%bind mini_c =
trace (simple_error "transpiling expression") @@
transpile_value typed in
let%bind michelson =
trace (simple_error "compiling expression") @@
Compiler.translate_value mini_c in
let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str
in
ok expr
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_filename in
let%bind () =
assert_entry_point_defined simplified entry_point in
let%bind typed =
trace (simple_error "typing file") @@
Typer.type_program simplified in
let%bind (_ , storage_ty) =
get_entry_point typed entry_point in
ok (typed , storage_ty)
in
let%bind expr =
let%bind simplified = parsify_expression syntax expression in
let%bind typed =
let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
in
trace (simple_error "typing expression") @@
Typer.type_expression env simplified in
let%bind () =
trace (simple_error "expression type doesn't match type storage") @@
Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in
let%bind mini_c =
trace (simple_error "transpiling expression") @@
transpile_value typed in
let%bind michelson =
trace (simple_error "compiling expression") @@
Compiler.translate_value mini_c in
let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str
in
ok expr
let type_file ?(debug_simplify = false) ?(debug_typed = false)
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)
) ;
let%bind typed =
trace (simple_error "typing") @@
Typer.type_program simpl in
(if debug_typed then (
Format.(printf "Typed : %a\n%!" Ast_typed.PP.program typed)
)) ;
ok typed
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 syntax source_filename in
let%bind storage_simpl =
parsify_expression syntax storage in
let%bind 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

70
src/main/run_typed.ml
View File

@ -1,70 +0,0 @@
open Trace
let transpile_value
(e:Ast_typed.annotated_expression) : Mini_c.value result =
let%bind f =
let open Transpiler in
let (f , _) = functionalize e in
let%bind main = translate_main f e.location in
ok main
in
let input = Mini_c.Combinators.d_unit in
let%bind r = Run_mini_c.run_entry f input in
ok r
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
(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
ok typed_result
let run_typed
?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string)
(program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result =
let%bind () =
let open Ast_typed in
let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in
let%bind (arg_ty , _) =
trace_strong (simple_error "entry-point doesn't have a function type") @@
get_t_function @@ get_type_annotation d.annotated_expression in
Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
in
let%bind mini_c_main =
trace (simple_error "transpile mini_c entry") @@
Transpiler.translate_entry program entry in
(if debug_mini_c then
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
) ;
let%bind mini_c_value = transpile_value input in
let%bind mini_c_result =
let error =
let title () = "run Mini_c" in
let content () =
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
in
error title content in
trace error @@
Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in
let%bind typed_result =
let%bind main_result_type =
let%bind typed_main = Ast_typed.get_functional_entry program entry in
match (snd typed_main).type_value' with
| T_function (_, result) -> ok result
| _ -> simple_fail "main doesn't have fun type" in
Transpiler.untranspile mini_c_result main_result_type in
ok typed_result

30
src/meta_michelson/alpha_wrap.ml
View File

@ -1,30 +0,0 @@
open Proto_alpha_utils.Error_monad
let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment ()
let tc = dummy_environment.tezos_context
module Proto_alpha = Proto_alpha_utils.Memory_proto_alpha
open Proto_alpha
open Alpha_context
open Alpha_environment
let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v
let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes ->
force_lwt ~msg:"unpacking : parse" (
if Compare.Int.(MBytes.length bytes >= 1) &&
Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
| None -> return None
| Some expr ->
Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x))
else
return None
)
let unpack ty a = match unpack_opt ty a with
| None -> raise @@ Failure "unpacking : of_bytes"
| Some x -> x
let blake2b b = Alpha_environment.Raw_hashes.blake2b b

317
src/meta_michelson/contract.ml
View File

@ -1,317 +0,0 @@
open Misc
open Proto_alpha_utils.Error_monad
open Memory_proto_alpha
open Alpha_context
open Script_ir_translator
open Script_typed_ir
module Option = Simple_utils.Option
module Cast = Proto_alpha_utils.Cast
type ('param, 'storage) toplevel = {
param_type : 'param ty ;
storage_type : 'storage ty ;
code : ('param * 'storage, packed_internal_operation list * 'storage) lambda
}
type ex_toplevel =
Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel
let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type =
let toplevel_str = Streams.read_file toplevel_path in
contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } ->
let toplevel_expr = Cast.tl_of_string toplevel_str in
let (param_ty_node, storage_ty_node, code_field) =
force_ok_alpha ~msg:"parsing toplevel" @@
parse_toplevel toplevel_expr in
let (Ex_ty param_type, _) =
force_ok_alpha ~msg:"parse arg ty" @@
Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in
let (Ex_ty storage_type, _) =
force_ok_alpha ~msg:"parse storage ty" @@
parse_storage_ty context storage_ty_node in
let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in
let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in
let param_type_full = Pair_t ((claimed_parameter_type, None, None),
(claimed_storage_type, None, None), None) in
let ret_type_full =
Pair_t ((List_t (Operation_t None, None), None, None),
(claimed_storage_type, None, None), None) in
parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type })
context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) ->
Error_monad.return {
param_type = claimed_parameter_type;
storage_type = claimed_storage_type;
code ;
}
let make_toplevel code storage_type param_type =
{ param_type ; storage_type ; code }
module type ENVIRONMENT = sig
val identities : identity list
val tezos_context : t
end
type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack
open Error_monad
module Step (Env: ENVIRONMENT) = struct
open Env
type config = {
source : Contract.t option ;
payer : Contract.t option ;
self : Contract.t option ;
visitor : (Script_interpreter.ex_descr_stack -> unit) option ;
timestamp : Script_timestamp.t option ;
debug_visitor : (ex_typed_stack -> unit) option ;
amount : Tez.t option ;
}
let no_config = {
source = None ;
payer = None ;
self = None ;
visitor = None ;
debug_visitor = None ;
timestamp = None ;
amount = None ;
}
let of_param base param = match param with
| None -> base
| Some _ as x -> x
let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () =
let base_config = Option.unopt ~default:no_config base_config in {
source = Option.bind_eager_or source base_config.source ;
payer = Option.bind_eager_or payer base_config.payer ;
self = Option.bind_eager_or self base_config.self ;
visitor = Option.bind_eager_or visitor base_config.visitor ;
debug_visitor = Option.bind_eager_or debug_visitor base_config.debug_visitor ;
timestamp = Option.bind_eager_or timestamp base_config.timestamp ;
amount = Option.bind_eager_or amount base_config.amount ;
}
open Error_monad
let debug_visitor ?f () =
let open Script_interpreter in
let aux (Ex_descr_stack (descr, stack)) =
(match (descr.instr, descr.bef) with
| Nop, Item_t (String_t _, stack_ty, _) -> (
let (Item (s, stack)) = stack in
if s = "_debug"
then (
match f with
| None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack
| Some f -> f (Ex_typed_stack(stack_ty, stack))
) else ()
)
| _ -> ()) ;
() in
aux
let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) =
let source = Option.unopt
~default:(List.nth identities 0).implicit_contract config.source in
let payer = Option.unopt
~default:(List.nth identities 1).implicit_contract config.payer in
let self = Option.unopt
~default:(List.nth identities 2).implicit_contract config.self in
let amount = Option.unopt ~default:(Tez.one) config.amount in
let visitor =
let default = debug_visitor ?f:config.debug_visitor () in
Option.unopt ~default config.visitor in
let tezos_context = match config.timestamp with
| None -> tezos_context
| Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in
Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) ->
return stack
let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) ->
return (b, c)
let step_3_1 ?config (a:'a) (b:'b) (c:'c)
(descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) ->
return d
let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) ->
return c
let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) ->
return b
let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) =
step_1_1 ?config a descr
let step ?config stack code =
force_lwt ~msg:"running a step" @@ step_lwt ?config stack code
end
let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} =
let { code ; _ } : (_, _) toplevel = toplevel in
let source = Option.unopt
~default:(List.nth identities 0).implicit_contract source in
let payer = Option.unopt
~default:(List.nth identities 1).implicit_contract payer in
let self = Option.unopt
~default:(List.nth identities 2).implicit_contract self in
let amount = Tez.one in
Script_interpreter.interp context ~source ~payer ~self amount code (param, storage)
>>=?? fun ((ops, storage), new_ctxt) ->
let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in
return (storage, ops, gas)
let run_lwt ?source ?payer ?self toplevel storage param env =
run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) ->
return storage
let run ?environment toplevel storage param =
contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param
let run_node ?environment toplevel storage_node param_node =
contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} ->
let {param_type ; storage_type ; _ } = toplevel in
parse_data context param_type param_node >>=?? fun (param, _) ->
parse_data context storage_type storage_node >>=?? fun (storage, _) ->
let storage = run toplevel storage param in
unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) ->
return storage_node
let run_str toplevel storage_str param_str =
let param_node = Cast.node_of_string param_str in
let storage_node = Cast.node_of_string storage_str in
run_node toplevel storage_node param_node
type input = {
toplevel_path : string ;
storage : string ;
parameter : string
}
let parse_json json_str : input =
let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in
let json = match json with
| `O json -> json
| _ -> raise @@ Failure "main_contract: not recorD"
in
let open Json in
let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in
let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in
let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in
{ toplevel_path ; storage ; parameter }
let generate_json (storage_node:Script.node) : string =
let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in
let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in
Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ;
Format.flush_str_formatter ()
module Types = struct
open Script_typed_ir
let union a b = Union_t ((a, None), (b, None), None)
let assert_union = function
| Union_t ((a, _), (b, _), _) -> (a, b)
| _ -> assert false
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
let assert_pair = function
| Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b)
| _ -> assert false
let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with
| Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b)
| _ -> raise (Failure msg)
let unit = Unit_t None
let bytes = Bytes_t None
let bytes_k = Bytes_key None
let nat = Nat_t None
let tez = Mutez_t None
let int = Int_t None
let nat_k = Nat_key None
let tez_k = Mutez_key None
let int_k = Int_key None
let big_map k v = Big_map_t (k, v, None)
let signature = Signature_t None
let operation = Operation_t None
let bool = Bool_t None
let mutez = Mutez_t None
let string = String_t None
let string_k = String_key None
let address_k = Address_key None
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
let option a = Option_t ((a, None), None, None)
let contract a = Contract_t (a, None)
let assert_option = function
| Option_t ((a, _), _, _) -> a
| _ -> assert false
let address = Address_t None
let lambda a b = Lambda_t (a, b, None)
let assert_lambda = function
| Lambda_t (a, b, _) -> (a, b)
| _ -> assert false
type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda
let is_lambda : type a . a ty -> ex_lambda option = function
| Lambda_t (_, _, _) as x -> Some (Ex_lambda x)
| _ -> None
let timestamp = Timestamp_t None
let timestamp_k = Timestamp_key None
let map a b = Map_t (a, b, None)
let assert_type (_:'a ty) (_:'a) = ()
end
module Values = struct
let empty_map t = empty_map t
let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = {
key_type ; value_type ; diff = empty_map comparable_key_ty ;
}
let int n = Script_int.of_int n
let nat n = Script_int.abs @@ Script_int.of_int n
let nat_to_int n = Option.unopt_exn @@ Script_int.to_int n
let tez n = Option.unopt_exn @@ Tez.of_mutez @@ Int64.of_int n
let left a = L a
let right b = R b
end

11
src/meta_michelson/dune
View File

@ -1,11 +0,0 @@
(library
(name meta_michelson)
(public_name ligo.meta_michelson)
(libraries
simple-utils
tezos-utils
proto-alpha-utils
michelson-parser
tezos-micheline
)
)

7
src/meta_michelson/json.ml
View File

@ -1,7 +0,0 @@
let force_record ~msg json = match json with
| `O json -> json
| _ -> raise @@ Failure ("not json record : " ^ msg)
let force_string ~msg json = match json with
| `String str -> str
| _ -> raise @@ Failure ("not json str : " ^ msg)

12
src/meta_michelson/meta_michelson.ml
View File

@ -1,12 +0,0 @@
module Run = struct
open Contract
let run_lwt_full = run_lwt_full
let run_lwt = run_lwt
let run_str = run_str
let run_node = run_node
let run = run
end
module Stack = Michelson_wrap.Stack
module Values = Contract.Values
module Types = Contract.Types

514
src/meta_michelson/michelson_wrap.ml
View File

@ -1,514 +0,0 @@
open Proto_alpha_utils.Memory_proto_alpha
module AC = Alpha_context
module Types = Contract.Types
module Option = Simple_utils.Option
module MBytes = Alpha_environment.MBytes
module Stack = struct
open Script_typed_ir
let descr bef aft instr =
{
loc = 0 ;
bef ; aft ; instr
}
type nonrec 'a ty = 'a ty
type 'a t = 'a stack_ty
type nonrec ('a, 'b) descr = ('a, 'b) descr
type ('a, 'b) code = ('a t) -> ('a, 'b) descr
type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty
type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr
type ex_code = Ex_code : ('a, 'b) code -> ex_code
let stack ?annot a b = Item_t (a, b, annot)
let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) =
let Item_t (hd, tl, _) = item in
(hd, tl)
let nil = Empty_t
let head x = fst @@ unstack x
let tail x = snd @@ unstack x
let seq a b bef =
let a_descr = a bef in
let b_descr = b a_descr.aft in
let aft = b_descr.aft in
descr bef aft @@ Seq (a_descr, b_descr)
let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack
let (@|) = seq
let (@:) = stack
let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d
let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack
let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc ->
descr ab.bef bc.aft @@ Seq(ab, bc)
let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr =
let bc_descr = code ab_descr.aft in
ab_descr <:: bc_descr
end
open Stack
type nat = AC.Script_int.n AC.Script_int.num
type int_num = AC.Script_int.z AC.Script_int.num
type bytes = MBytes.t
type address = AC.Contract.t Script_typed_ir.ty
type mutez = AC.Tez.t Script_typed_ir.ty
module Stack_ops = struct
open Script_typed_ir
let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef ->
let Item_t (ty, rest, _) = bef in
descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup
let drop : ('a * 'rest, 'rest) code = fun bef ->
let aft = snd @@ unstack bef in
descr bef aft Drop
let swap (bef : (('a * ('b * 'c)) stack_ty)) =
let Item_t (a, Item_t (b, rest, _), _) = bef in
descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap
let dip code (bef : ('ty * 'rest) stack_ty) =
let Item_t (ty, rest, _) = bef in
let applied = code rest in
let aft = Item_t (ty, applied.aft, None) in
descr bef aft (Dip (code rest))
let noop : ('r, 'r) code = fun bef ->
descr bef bef Nop
let exec : (_, _) code = fun bef ->
let lambda = head @@ tail bef in
let (_, ret) = Types.assert_lambda lambda in
let aft = ret @: (tail @@ tail bef) in
descr bef aft Exec
let fail aft : ('a * 'r, 'b) code = fun bef ->
let head = fst @@ unstack bef in
descr bef aft (Failwith head)
let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr =
let aft = Item_t (Types.string, bef, None) in
descr bef aft (Const (str))
let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r ->
let aft = stack (Types.option a) r in
descr r aft (Const None)
let push_unit : ('rest, unit * 'rest) code = fun r ->
let aft = stack Types.unit r in
descr r aft (Const ())
let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr =
let aft = Item_t (Types.nat, bef, None) in
descr bef aft (Const (Contract.Values.nat n))
let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr =
let aft = Types.int @: bef in
descr bef aft (Const (Contract.Values.int n))
let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr =
let aft = Types.mutez @: bef in
descr bef aft (Const (Contract.Values.tez n))
let push_bool b : ('s, bool * 's) code = fun bef ->
let aft = stack Types.bool bef in
descr bef aft (Const b)
let push_generic ty v : ('s, _ * 's) code = fun bef ->
let aft = stack ty bef in
descr bef aft (Const v)
let failstring str aft =
push_string str @| fail aft
end
module Stack_shortcuts = struct
open Stack_ops
let diip c x = dip (dip c) x
let diiip c x = dip (diip c) x
let diiiip c x = dip (diiip c) x
let bubble_1 = swap
let bubble_down_1 = swap
let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef ->
bef <. dip swap <: swap
let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef ->
bef <. swap <: dip swap
let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef ->
bef <. diip swap <: dip swap <: swap
let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef ->
bef <. dup <: dip code
let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s ->
s <. keep_1 code <: swap
let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef ->
(dup @| dip (swap @| dup @| dip (swap @| code))) bef
let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef ->
(dip dup @| swap @| dip code) bef
let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s ->
let aft = head d.aft @: tail s in
descr s aft d.instr
end
module Pair_ops = struct
let car (bef : (('a * 'b) * 'rest) Stack.t) =
let (pair, rest) = unstack bef in
let (a, _) = Contract.Types.assert_pair pair in
descr bef (stack a rest) Car
let cdr (bef : (('a * 'b) * 'rest) Stack.t) =
let (pair, rest) = unstack bef in
let (_, b) = Contract.Types.assert_pair pair in
descr bef (stack b rest) Cdr
let pair (bef : ('a * ('b * 'rest)) Stack.t) =
let (a, rest) = unstack bef in
let (b, rest) = unstack rest in
let aft = (Types.pair a b) @: rest in
descr bef aft Cons_pair
open Stack_ops
let carcdr s = s <. car <: Stack_ops.dip cdr
let cdrcar s = s <. cdr <: dip car
let cdrcdr s = s <. cdr <: dip cdr
let carcar s = s <. car <: dip car
let cdar s = s <. cdr <: car
let unpair s = s <. dup <: car <: dip cdr
end
module Option_ops = struct
open Script_typed_ir
let cons bef =
let (hd, tl) = unstack bef in
descr bef (stack (Contract.Types.option hd) tl) Cons_some
let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef ->
let (a_opt, base) = unstack bef in
let a = Types.assert_option a_opt in
let target = Option.unopt ~default:(none_branch base).aft target in
descr bef target (If_none (none_branch base, some_branch (stack a base)))
let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s ->
let (a_opt, base) = unstack s in
let a = Types.assert_option a_opt in
let target = a @: base in
cond ~target
(Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target)
Stack_ops.noop s
end
module Union_ops = struct
open Script_typed_ir
let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef ->
let (a, base) = unstack bef in
let aft = Types.union a b @: base in
descr bef aft Left
let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef ->
let (b, base) = unstack bef in
let aft = Types.union a b @: base in
descr bef aft Right
let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef ->
let (union, base) = unstack bef in
let (a, b) = Types.assert_union union in
let code_stack = a @: base in
let aft = Option.unopt ~default:(b @: base) after in
descr bef aft (Loop_left (code code_stack))
end
module Arithmetic = struct
let neq : (int_num * 'r, bool *'r) code = fun bef ->
let aft = stack Types.bool @@ snd @@ unstack bef in
descr bef aft Neq
let neg : (int_num * 'r, int_num *'r) code = fun bef ->
let aft = stack Types.int @@ snd @@ unstack bef in
descr bef aft Neg_int
let abs : (int_num * 'r, nat *'r) code = fun bef ->
let aft = stack Types.nat @@ snd @@ unstack bef in
descr bef aft Abs_int
let int : (nat * 'r, int_num*'r) code = fun bef ->
let aft = stack Types.int @@ snd @@ unstack bef in
descr bef aft Int_nat
let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef ->
let aft = stack Types.(option nat) @@ tail bef in
descr bef aft Is_nat
let nat_neq = fun s -> (int @| neq) s
let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
let (nat, rest) = unstack bef in
let rest = tail rest in
let aft = stack nat rest in
descr bef aft Add_natnat
let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
let (nat, rest) = unstack bef in
let rest = tail rest in
let aft = stack nat rest in
descr bef aft Add_intint
let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef ->
let aft = tail bef in
descr bef aft Add_tez
let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
let nat = head bef in
let rest = tail @@ tail bef in
let aft = stack nat rest in
descr bef aft Mul_natnat
let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
let nat = head bef in
let rest = tail @@ tail bef in
let aft = stack nat rest in
descr bef aft Mul_intint
let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef ->
let aft = tail bef in
descr bef aft Sub_int
let sub_natnat : (nat * (nat * 'r), int_num * 'r) code =
fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint
let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s ->
let (n, base) = unstack @@ snd @@ unstack s in
let aft = Types.option (Types.pair n n) @: base in
descr s aft Ediv_natnat
let ediv_tez = fun s ->
let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in
descr s aft Ediv_teznat
open Option_ops
let force_ediv x = x <. ediv <: force_some
let force_ediv_tez x = (ediv_tez @| force_some) x
open Pair_ops
let div x = x <. force_ediv <: car
open Stack_ops
let div_n n s = s <. push_nat n <: swap <: div
let add_n n s = s <. push_nat n <: swap <: add_natnat
let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez
let sub_n n s = s <. push_nat n <: swap <: sub_natnat
let force_nat s = s <. nat_opt <: force_some ~msg:"force nat"
end
module Boolean = struct
let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef ->
let aft = Types.bool @: tail @@ tail bef in
descr bef aft And
let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef ->
let aft = Types.bool @: tail @@ tail bef in
descr bef aft Or
open Script_typed_ir
let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef ->
let base = tail bef in
let aft = Option.unopt ~default:((true_branch base).aft) target in
descr bef aft (If (true_branch base, false_branch base))
let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef ->
let aft = tail bef in
descr bef aft @@ Loop (code aft)
end
module Comparison_ops = struct
let cmp c_ty : _ code = fun bef ->
let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in
descr bef aft (Compare c_ty)
let cmp_bytes = fun x -> cmp (Bytes_key None) x
let eq : (int_num * 'r, bool *'r) code = fun bef ->
let aft = stack Contract.Types.bool @@ snd @@ unstack bef in
descr bef aft Eq
open Arithmetic
let eq_n n s = s <. sub_n n <: eq
let ge : (int_num * 'r, bool * 'r) code = fun bef ->
let base = tail bef in
let aft = stack Types.bool base in
descr bef aft Ge
let gt : (int_num * 'r, bool * 'r) code = fun bef ->
let base = tail bef in
let aft = stack Types.bool base in
descr bef aft Gt
let lt : (int_num * 'r, bool * 'r) code = fun bef ->
let base = tail bef in
let aft = stack Types.bool base in
descr bef aft Lt
let gt_nat s = s <. int <: gt
open Stack_ops
let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s)
let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef ->
bef <. sub_natnat <: ge
let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef ->
bef <. cmp Types.timestamp_k <: ge
let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef ->
bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef))
let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef ->
bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef))
end
module Bytes = struct
open Script_typed_ir
let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef ->
let aft = stack Types.bytes @@ tail bef in
descr bef aft (Pack ty)
let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef ->
let aft = stack (Types.option ty) (tail bef) in
descr bef aft (Unpack ty)
let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some
let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef ->
let aft = tail bef in
descr bef aft Concat_bytes_pair
let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
descr bef bef Sha256
let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
descr bef bef Blake2b
end
module Map = struct
open Script_typed_ir
type ('a, 'b) t = ('a, 'b) map
let empty c_ty = Script_ir_translator.empty_map c_ty
let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m
module Ops = struct
let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr =
let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in
let aft = Item_t (map, rest, None) in
descr bef aft Map_update
let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef ->
let _ = a in
let base = snd @@ unstack @@ snd @@ unstack bef in
let aft = stack (Types.option b) base in
descr bef aft Map_get
let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef ->
let base = snd @@ unstack @@ snd @@ unstack bef in
let aft = stack (Types.option b) base in
descr bef aft Big_map_get
let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef ->
let base = tail @@ tail bef in
descr bef base Big_map_update
end
end
module List_ops = struct
let nil ele bef =
let aft = stack (Types.list ele) bef in
descr bef aft Nil
let cons bef =
let aft = tail bef in
descr bef aft Cons_list
let cond ~target cons_branch nil_branch bef =
let (lst, aft) = unstack bef in
let a = Types.assert_list lst in
let cons_descr = cons_branch (a @: Types.list a @: aft) in
let nil_descr = nil_branch aft in
descr bef target (If_cons (cons_descr, nil_descr))
let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef ->
let (a_lst, aft) = unstack bef in
let a = Types.assert_list a_lst in
descr bef aft (List_iter (code (a @: aft)))
end
module Tez = struct
let amount : ('r, AC.Tez.t * 'r) code = fun bef ->
let aft = Types.mutez @: bef in
descr bef aft Amount
open Bytes
let tez_nat s = s <. pack Types.mutez <: unpack Types.nat
let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat
end
module Misc = struct
open Stack_ops
open Stack_shortcuts
open Comparison_ops
let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s ->
s <.
keep_2 cmp_ge_nat <: bubble_2 <:
Boolean.cond drop (dip drop)
let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop
let debug_msg msg = debug ~msg ()
let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef ->
let aft = stack Types.timestamp bef in
descr bef aft Now
end

302
src/meta_michelson/misc.ml
View File

@ -1,302 +0,0 @@
module Signature = Tezos_base.TzPervasives.Signature
open Proto_alpha_utils.Memory_proto_alpha
module Data_encoding = Alpha_environment.Data_encoding
module MBytes = Alpha_environment.MBytes
module Error_monad = Proto_alpha_utils.Error_monad
open Error_monad
module Context_init = struct
type account = {
pkh : Signature.Public_key_hash.t ;
pk : Signature.Public_key.t ;
sk : Signature.Secret_key.t ;
}
let generate_accounts n : (account * Tez_repr.t) list =
let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
List.map (fun _ ->
let (pkh, pk, sk) = Signature.generate_key () in
let account = { pkh ; pk ; sk } in
account, amount)
(Simple_utils.List.range n)
let make_shell
~level ~predecessor ~timestamp ~fitness ~operations_hash =
Tezos_base.Block_header.{
level ;
predecessor ;
timestamp ;
fitness ;
operations_hash ;
(* We don't care of the following values, only the shell validates them. *)
proto_level = 0 ;
validation_passes = 0 ;
context = Alpha_environment.Context_hash.zero ;
}
let default_proof_of_work_nonce =
MBytes.create Alpha_context.Constants.proof_of_work_nonce_size
let protocol_param_key = [ "protocol_parameters" ]
let check_constants_consistency constants =
let open Constants_repr in
let open Error_monad in
let { blocks_per_cycle ; blocks_per_commitment ;
blocks_per_roll_snapshot ; _ } = constants in
Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
(fun () -> failwith "Inconsistent constants : blocks per commitment must be \
less than blocks per cycle") >>=? fun () ->
Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
(fun () -> failwith "Inconsistent constants : blocks per cycle \
must be superior than blocks per roll snapshot") >>=?
return
let initial_context
constants
header
commitments
initial_accounts
security_deposit_ramp_up_cycles
no_reward_cycles
=
let open Tezos_base.TzPervasives.Error_monad in
let bootstrap_accounts =
List.map (fun ({ pk ; pkh ; _ }, amount) ->
let open! Parameters_repr in
{ public_key_hash = pkh ; public_key = Some pk ; amount }
) initial_accounts
in
let json =
Data_encoding.Json.construct
Parameters_repr.encoding
Parameters_repr.{
bootstrap_accounts ;
bootstrap_contracts = [] ;
commitments ;
constants ;
security_deposit_ramp_up_cycles ;
no_reward_cycles ;
}
in
let proto_params =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
Tezos_protocol_environment_memory.Context.(
set empty ["version"] (MBytes.of_string "genesis")
) >>= fun ctxt ->
Tezos_protocol_environment_memory.Context.(
set ctxt protocol_param_key proto_params
) >>= fun ctxt ->
Main.init ctxt header
>|= Alpha_environment.wrap_error >>=? fun { context; _ } ->
return context
let genesis
?(preserved_cycles = Constants_repr.default.preserved_cycles)
?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle)
?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment)
?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot)
?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period)
?(time_between_blocks = Constants_repr.default.time_between_blocks)
?(endorsers_per_block = Constants_repr.default.endorsers_per_block)
?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation)
?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block)
?(proof_of_work_threshold = Int64.(neg one))
?(tokens_per_roll = Constants_repr.default.tokens_per_roll)
?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size)
?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip)
?(origination_size = Constants_repr.default.origination_size)
?(block_security_deposit = Constants_repr.default.block_security_deposit)
?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit)
?(block_reward = Constants_repr.default.block_reward)
?(endorsement_reward = Constants_repr.default.endorsement_reward)
?(cost_per_byte = Constants_repr.default.cost_per_byte)
?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation)
?(commitments = [])
?(security_deposit_ramp_up_cycles = None)
?(no_reward_cycles = None)
(initial_accounts : (account * Tez_repr.t) list)
=
if initial_accounts = [] then
Pervasives.failwith "Must have one account with a roll to bake";
(* Check there is at least one roll *)
let open Tezos_base.TzPervasives.Error_monad in
begin try
let (>>?=) x y = match x with
| Ok(a) -> y a
| Error(b) -> fail @@ List.hd b in
fold_left_s (fun acc (_, amount) ->
Alpha_environment.wrap_error @@
Tez_repr.(+?) acc amount >>?= fun acc ->
if acc >= tokens_per_roll then
raise Exit
else return acc
) Tez_repr.zero initial_accounts >>=? fun _ ->
failwith "Insufficient tokens in initial accounts to create one roll"
with Exit -> return ()
end >>=? fun () ->
let constants : Constants_repr.parametric = {
preserved_cycles ;
blocks_per_cycle ;
blocks_per_commitment ;
blocks_per_roll_snapshot ;
blocks_per_voting_period ;
time_between_blocks ;
endorsers_per_block ;
hard_gas_limit_per_operation ;
hard_gas_limit_per_block ;
proof_of_work_threshold ;
tokens_per_roll ;
michelson_maximum_type_size ;
seed_nonce_revelation_tip ;
origination_size ;
block_security_deposit ;
endorsement_security_deposit ;
block_reward ;
endorsement_reward ;
cost_per_byte ;
hard_storage_limit_per_operation ;
} in
check_constants_consistency constants >>=? fun () ->
let hash =
Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
in
let shell = make_shell
~level:0l
~predecessor:hash
~timestamp:Tezos_utils.Time.epoch
~fitness: (Fitness_repr.from_int64 0L)
~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
initial_context
constants
shell
commitments
initial_accounts
security_deposit_ramp_up_cycles
no_reward_cycles
>>=? fun context ->
return (context, shell, hash)
let init
?(slow=false)
?preserved_cycles
?endorsers_per_block
?commitments
n =
let open Error_monad in
let accounts = generate_accounts n in
let contracts = List.map (fun (a, _) ->
Alpha_context.Contract.implicit_contract (a.pkh)) accounts in
begin
if slow then
genesis
?preserved_cycles
?endorsers_per_block
?commitments
accounts
else
genesis
?preserved_cycles
~blocks_per_cycle:32l
~blocks_per_commitment:4l
~blocks_per_roll_snapshot:8l
~blocks_per_voting_period:(Int32.mul 32l 8l)
?endorsers_per_block
?commitments
accounts
end >>=? fun ctxt ->
return (ctxt, accounts, contracts)
let contents
?(proof_of_work_nonce = default_proof_of_work_nonce)
?(priority = 0) ?seed_nonce_hash () =
Alpha_context.Block_header.({
priority ;
proof_of_work_nonce ;
seed_nonce_hash ;
})
let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt =
let contents = contents ~priority () in
let protocol_data =
let open! Alpha_context.Block_header in {
contents ;
signature = Signature.zero ;
} in
let header = {
Alpha_context.Block_header.shell = {
predecessor = hash ;
proto_level = header.proto_level ;
validation_passes = header.validation_passes ;
fitness = header.fitness ;
timestamp ;
level = header.level ;
context = Alpha_environment.Context_hash.zero ;
operations_hash = Alpha_environment.Operation_list_list_hash.zero ;
} ;
protocol_data = {
contents ;
signature = Signature.zero ;
} ;
} in
Main.begin_construction
~chain_id: Alpha_environment.Chain_id.zero
~predecessor_context: ctxt
~predecessor_timestamp: header.shell.timestamp
~predecessor_fitness: header.shell.fitness
~predecessor_level: header.shell.level
~predecessor:hash
~timestamp
~protocol_data
() >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state ->
return state.ctxt
let main n =
init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
let timestamp = Tezos_base.Time.now () in
begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
return (ctxt, accounts, contracts)
end
type identity = {
public_key_hash : Signature.public_key_hash;
public_key : Signature.public_key;
secret_key : Signature.secret_key;
implicit_contract : Alpha_context.Contract.t;
}
type environment = {
tezos_context : Alpha_context.t ;
identities : identity list ;
}
let init_environment () =
Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) ->
let accounts = List.map fst accounts in
let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in
let identities =
List.map (fun ((a:Context_init.account), c) -> {
public_key = a.pk ;
public_key_hash = a.pkh ;
secret_key = a.sk ;
implicit_contract = c ;
}) @@
List.combine accounts contracts in
return {tezos_context ; identities}
let contextualize ~msg ?environment f =
let lwt =
let environment = match environment with
| None -> init_environment ()
| Some x -> return x in
environment >>=? f
in
force_ok ~msg @@ Lwt_main.run lwt

18
src/meta_michelson/streams.ml
View File

@ -1,18 +0,0 @@
let read_file f =
let ic = open_in f in
let n = in_channel_length ic in
let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
Bytes.to_string s
let read_lines filename =
let lines = ref [] in
let chan = open_in filename in
try
while true; do
lines := input_line chan :: !lines
done; !lines
with End_of_file ->
close_in chan;
List.rev !lines

21
src/parser/pascaligo/.gitlab-ci.yml
View File

@ -1,21 +0,0 @@
before_script:
- apt-get update -qq
- apt-get -y -qq install libhidapi-dev libcap-dev bubblewrap
- 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
- export PATH="/usr/local/bin${PATH:+:}${PATH:-}"
- echo "$PATH"
- printf '' | opam init
- eval $(opam config env)
- opam repository add tezos-opam-repository https://gitlab.com/ligolang/tezos-opam-repository.git
- eval $(opam config env)
- opam --version
- printf '' | ocaml
default-job:
script:
- opam install -y --working-dir .
artifacts:
paths:
- Parser.exe

0
src/parser/camligo/.gitignore → src/passes/1-parser/camligo/.gitignore vendored
View File

0
src/parser/camligo/ast.ml → src/passes/1-parser/camligo/ast.ml
View File

12
src/parser/camligo/dune → src/passes/1-parser/camligo/dune
View File

@ -10,7 +10,7 @@
(flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils ))
(preprocess
(pps
simple-utils.ppx_let_generalized
ppx_let
ppx_deriving.std
)
)
@ -28,7 +28,7 @@
(targets parser_generated.mly)
(deps partial_parser.mly pre_parser.mly)
(action (system "cat pre_parser.mly partial_parser.mly > parser_generated.mly"))
(mode promote-until-clean)
(mode (promote (until-clean) (only *)))
)
(rule
@ -43,7 +43,7 @@
(targets ast_generated.ml)
(deps generator.exe)
(action (system "./generator.exe ast > ast_generated.ml"))
(mode promote-until-clean)
(mode (promote (until-clean) (only *)))
)
;; Generating Generator
@ -57,4 +57,10 @@
lex
)
(modules generator)
(preprocess
(pps
ppx_let
ppx_deriving.std
)
)
)

0
src/parser/camligo/generator.ml → src/passes/1-parser/camligo/generator.ml
View File

0
src/parser/camligo/lex/dune → src/passes/1-parser/camligo/lex/dune
View File

0
src/parser/camligo/lex/generator.ml → src/passes/1-parser/camligo/lex/generator.ml
View File

0
src/parser/camligo/location.ml → src/passes/1-parser/camligo/location.ml
View File

0
src/parser/camligo/parser_camligo.ml → src/passes/1-parser/camligo/parser_camligo.ml
View File

0
src/parser/camligo/pre_parser.mly → src/passes/1-parser/camligo/pre_parser.mly
View File

0
src/parser/camligo/user.ml → src/passes/1-parser/camligo/user.ml
View File

2
src/parser/dune → src/passes/1-parser/dune
View File

@ -10,7 +10,7 @@
parser_ligodity
)
(preprocess
(pps simple-utils.ppx_let_generalized)
(pps ppx_let)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared ))
)

0
src/parser/generator/doc/essai.ml → src/passes/1-parser/generator/doc/essai.ml
View File

0
src/parser/generator/doc/mini_ml.bnf → src/passes/1-parser/generator/doc/mini_ml.bnf
View File

0
src/parser/generator/doc/mini_ml2.bnf → src/passes/1-parser/generator/doc/mini_ml2.bnf
View File

0
src/parser/generator/doc/mini_ml3.bnf → src/passes/1-parser/generator/doc/mini_ml3.bnf
View File

0
src/parser/generator/doc/mini_ml4.bnf → src/passes/1-parser/generator/doc/mini_ml4.bnf
View File

0
src/parser/ligodity.ml → src/passes/1-parser/ligodity.ml
View File

0
src/parser/ligodity/.AST.ml.tag → src/passes/1-parser/ligodity/.AST.ml.tag
View File

0
src/parser/ligodity/.Eval.ml.tag → src/passes/1-parser/ligodity/.Eval.ml.tag
View File

0
src/parser/ligodity/.EvalMain.ml.tag → src/passes/1-parser/ligodity/.EvalMain.ml.tag
View File

0
src/parser/ligodity/.Lexer.ml.tag → src/passes/1-parser/ligodity/.Lexer.ml.tag
View File

0
src/parser/ligodity/.LexerMain.tag → src/passes/1-parser/ligodity/.LexerMain.tag
View File

0
src/parser/ligodity/.Parser.ml.tag → src/passes/1-parser/ligodity/.Parser.ml.tag
View File

0
src/parser/ligodity/.Parser.mly.tag → src/passes/1-parser/ligodity/.Parser.mly.tag
View File

0
src/parser/ligodity/.ParserMain.tag → src/passes/1-parser/ligodity/.ParserMain.tag
View File

0
src/parser/ligodity/.links → src/passes/1-parser/ligodity/.links
View File

0
src/parser/ligodity/AST.ml → src/passes/1-parser/ligodity/AST.ml
View File

0
src/parser/ligodity/AST.mli → src/passes/1-parser/ligodity/AST.mli
View File

0
src/parser/ligodity/EvalOpt.ml → src/passes/1-parser/ligodity/EvalOpt.ml
View File

0
src/parser/ligodity/EvalOpt.mli → src/passes/1-parser/ligodity/EvalOpt.mli
View File

0
src/parser/ligodity/Lexer.mli → src/passes/1-parser/ligodity/Lexer.mli
View File

0
src/parser/ligodity/Lexer.mll → src/passes/1-parser/ligodity/Lexer.mll
View File

0
src/parser/ligodity/LexerMain.ml → src/passes/1-parser/ligodity/LexerMain.ml
View File

0
src/parser/ligodity/ParToken.mly → src/passes/1-parser/ligodity/ParToken.mly
View File

0
src/parser/ligodity/Parser.mly → src/passes/1-parser/ligodity/Parser.mly
View File

0
src/parser/ligodity/ParserMain.ml → src/passes/1-parser/ligodity/ParserMain.ml
View File

0
src/parser/ligodity/Stubs/Simple_utils.ml → src/passes/1-parser/ligodity/Stubs/Simple_utils.ml
View File

0
src/parser/ligodity/Tests/match.mml → src/passes/1-parser/ligodity/Tests/match.mml
View File

0
src/parser/ligodity/Token.ml → src/passes/1-parser/ligodity/Token.ml
View File

Some files were not shown because too many files have changed in this diff Show More