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

.gitignore

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

.gitlab-ci.yml

@@ -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.
+    - scripts/install_opam.sh # TODO: or scripts/install_build_environment.sh ?
-    - 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:-}"
-
-    # Initialise opam
-    - printf '' | opam init --bare
     - eval $(opam config env)
-
+    - scripts/setup_switch.sh
-    # Create switch
-    - printf '' | opam switch create toto ocaml-base-compiler.4.06.1
     - eval $(opam config env)
-
+    - scripts/setup_repos.sh
-    # Show versions and current switch
-    - echo "$PATH"
-    - opam --version
-    - printf '' | ocaml
-    - opam switch
 
     # install deps for internal documentation
+    - scripts/install_vendors_deps.sh
     - opam install -y odoc
-    - vendors/opam-repository-tools/rewrite-local-opam-repository.sh
+    - scripts/build_ligo_local.sh
-    - opam repository add localrepo "file://$PWD/vendors/ligo-opam-repository-local-generated/"
-    - opam install -y --build-test --deps-only ./src/
-    - dune build -p ligo
-    # TODO: also try instead from time to time:
-    #- (cd ./src/; dune build -p ligo)
 
     # build with odoc
     - dune build @doc
@@ -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)
-
+    - scripts/setup_switch.sh
-    # Show versions and current switch
+    - eval $(opam config env)
-    - echo "$PATH"
+    - scripts/setup_repos.sh
-    - opam --version
-    - printf '' | ocaml
-    - opam switch
 
 local-dune-job:
   <<: *before_script
   stage: test
   script:
-    - scripts/setup_ligo_opam_repository.sh
+    - scripts/install_vendors_deps.sh
-    - opam install -y --build-test --deps-only ./src/
+    - scripts/build_ligo_local.sh
-    - dune build -p ligo
-    # TODO: also try instead from time to time:
-    #- (cd ./src/; dune build -p ligo)
     - 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
+  script:
-  after_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

Makefile

@@ -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
+	export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
-	scripts/install_opam.sh
+#	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

docker/Dockerfile

@@ -1,6 +1,5 @@
-# We could use one of the nomadiclab's docker images as a base instead
+# At the moment, this really means 4.07.1
-# 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.07
-FROM ocaml/opam2:4.06
 
 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
+# Install OPAM
-RUN sh scripts/setup_ligo_opam_repository.sh
+# 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" ]

gitlab-pages/website/pages/en/versions.js

@@ -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}/${
+  const repoUrl = `${siteConfig.repoUrl}`;
-    siteConfig.projectName
-  }`;
   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">

makefile

@@ -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

scripts/build_ligo_local.sh

@@ -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)

scripts/install_build_environment.sh

@@ -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`" ]

scripts/install_ligo_with_dependencies.sh

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

scripts/install_opam.sh

@@ -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

scripts/install_vendors_deps.sh

@@ -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)

scripts/ligo_ci.sh

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

scripts/setup_dev_switch.sh

@@ -1,4 +1,8 @@
-opam switch create . ocaml-base-compiler.4.06.1
+#!/bin/sh
-eval $(opam env)
+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

scripts/setup_repos.sh

@@ -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

scripts/setup_switch.sh

@@ -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)

scripts/test_cli.sh

@@ -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";

scripts/test_ligo.sh

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

src/README_INSTALL

@@ -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

src/bin/cli.ml

@@ -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 =
+  let f source entry_point syntax display_format michelson_format =
-    toplevel @@
+    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
+      Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in
-    Format.printf "%s\n" contract ;
+    ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract
-    ok ()
   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 =
+  let f source entry_point expression syntax display_format =
-    toplevel @@
+    toplevel ~display_format @@
     let%bind value =
       trace (simple_error "compile-input") @@
-      Ligo.Run.compile_contract_parameter source entry_point expression (Syntax_name syntax) in
+      Ligo.Run.Of_source.compile_file_contract_parameter source entry_point expression (Syntax_name syntax) in
-    Format.printf "%s\n" value;
+    ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value
-    ok ()
   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 =
+  let f source entry_point expression syntax display_format bigmap =
-    toplevel @@
+    toplevel ~display_format @@
     let%bind value =
       trace (simple_error "compile-storage") @@
-      Ligo.Run.compile_contract_storage source entry_point expression (Syntax_name syntax) in
+      Ligo.Run.Of_source.compile_file_contract_storage ~value:bigmap source entry_point expression (Syntax_name syntax) in
-    Format.printf "%s\n" value;
+    ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value
-    ok ()
   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 =
+  let f source entry_point storage input amount syntax display_format bigmap =
-    toplevel @@
+    toplevel ~display_format @@
     let%bind output =
-      Ligo.Run.run_contract ~amount source entry_point storage input (Syntax_name syntax) in
+      Ligo.Run.Of_source.run_contract ~amount ~storage_value:bigmap source entry_point storage input (Syntax_name syntax) in
-    Format.printf "%a\n" Ast_simplified.PP.expression output ;
+    ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output
-    ok ()
   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 =
+  let f source entry_point parameter amount syntax display_format =
-    toplevel @@
+    toplevel ~display_format @@
     let%bind output =
-      Ligo.Run.run_function ~amount source entry_point parameter (Syntax_name syntax) in
+      Ligo.Run.Of_source.run_function_entry ~amount source entry_point parameter (Syntax_name syntax) in
-    Format.printf "%a\n" Ast_simplified.PP.expression output ;
+    ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output
-    ok ()
   in
   let term =
-    Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ syntax) in
+    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 =
+  let f source entry_point amount syntax display_format =
-    toplevel @@
+    toplevel ~display_format @@
     let%bind output =
-      Ligo.Run.evaluate_value ~amount source entry_point (Syntax_name syntax) in
+      Ligo.Run.Of_source.evaluate_entry ~amount source entry_point (Syntax_name syntax) in
-    Format.printf "%a\n" Ast_simplified.PP.expression output ;
+    ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output
-    ok ()
   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 ;

src/bin/cli_helpers.ml

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

src/bin/dune

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

src/compiler/compiler_environment.ml

@@ -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

src/compiler/compiler_program.ml

@@ -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

src/contracts/annotation.ligo

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

src/contracts/error_type.ligo

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

src/contracts/for_fail.ligo

@@ -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;

src/contracts/included.ligo

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

src/contracts/includer.ligo

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

src/contracts/list.mligo

@@ -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)

src/contracts/procedure.ligo

@@ -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 

src/dune

@@ -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/*))  
-)

src/dune-project

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

src/main/compile/dune

@@ -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 ))
+)

src/main/compile/helpers.ml

@@ -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

src/main/compile/of_mini_c.ml

@@ -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

src/main/compile/of_simplified.ml

@@ -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

src/main/compile/of_source.ml

@@ -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

src/main/compile/of_typed.ml

@@ -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

src/main/display.ml

@@ -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
+  if not dev then (
     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 *)
+  ) 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

src/main/dune

@@ -2,20 +2,11 @@
   (name main)
   (public_name ligo.main)
   (libraries
-    simple-utils
+    run
-    tezos-utils
+    compile
-    parser
-    simplify
-    ast_simplified
-    typer
-    ast_typed
-    transpiler
-    mini_c
-    operators
-    compiler
   )
   (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 ))
 )

src/main/main.ml

@@ -1,137 +1,3 @@
-module Run_mini_c = Run_mini_c
+module Run = Run
-
+module Compile = Compile
-(* 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 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 *)

src/main/run/dune

@@ -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 ))
+)

src/main/run/of_michelson.ml

@@ -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

src/main/run/of_mini_c.ml

@@ -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

src/main/run/of_simplified.ml

@@ -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

src/main/run/of_source.ml

@@ -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
+
+

src/main/run/of_typed.ml

@@ -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

src/main/run/run.ml

@@ -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

src/main/run_mini_c.ml

@@ -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

src/main/run_simplified.ml

@@ -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

src/main/run_source.ml

@@ -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

src/main/run_typed.ml

@@ -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

src/meta_michelson/alpha_wrap.ml

@@ -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

src/meta_michelson/contract.ml

@@ -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

src/meta_michelson/dune

@@ -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
- )
-)

src/meta_michelson/json.ml

@@ -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)

src/meta_michelson/meta_michelson.ml

@@ -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
-

src/meta_michelson/michelson_wrap.ml

@@ -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
-
-
-

src/meta_michelson/misc.ml

@@ -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

src/meta_michelson/streams.ml

@@ -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

src/parser/pascaligo/.gitlab-ci.yml

@@ -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

src/passes/1-parser/camligo/dune

@@ -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
+    )
+  )
 )

src/passes/1-parser/dune

@@ -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 ))
 )