From 97a85766d333d592c34ced3d046dba371b60ea1a Mon Sep 17 00:00:00 2001
From: Lesenechal Remi <lesenechal.remi@gmail.com>
Date: Thu, 12 Mar 2020 20:16:50 +0100
Subject: [PATCH] add a flag to disable michelson typechecking in
 compile-contract

---
 src/bin/cli.ml                     | 13 ++++++++++---
 src/bin/expect_tests/help_tests.ml |  4 ++++
 src/main/compile/of_michelson.ml   | 27 +++++++++++++++------------
 3 files changed, 29 insertions(+), 15 deletions(-)

diff --git a/src/bin/cli.ml b/src/bin/cli.ml
index a35e5d91c..ad36e987c 100644
--- a/src/bin/cli.ml
+++ b/src/bin/cli.ml
@@ -94,6 +94,13 @@ let source =
     info ~docv ~doc ["source"] in
   value @@ opt (some string) None info
 
+let disable_michelson_typechecking =
+  let open Arg in
+  let info =
+    let doc = "disable Michelson typecking, this might produce ill-typed Michelson code." in
+    info ~doc ["disable-michelson-typechecking"] in
+  value @@ flag info
+
 let predecessor_timestamp =
   let open Arg in
   let info =
@@ -131,17 +138,17 @@ module Uncompile = Ligo.Uncompile
 module Run = Ligo.Run.Of_michelson
 
 let compile_file =
-  let f source_file entry_point syntax display_format michelson_format =
+  let f source_file entry_point syntax display_format disable_typecheck michelson_format =
     toplevel ~display_format @@
     let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
     let%bind typed,_    = Compile.Of_simplified.compile (Contract entry_point) simplified in
     let%bind mini_c     = Compile.Of_typed.compile typed in
     let%bind michelson  = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
-    let%bind contract   = Compile.Of_michelson.build_contract michelson in
+    let%bind contract   = Compile.Of_michelson.build_contract ~disable_typecheck michelson in
     ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract
   in
   let term =
-    Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ michelson_code_format) in
+    Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ disable_michelson_typechecking $ michelson_code_format) in
   let cmdname = "compile-contract" in
   let doc = "Subcommand: Compile a contract." in
   (Term.ret term , Term.info ~doc cmdname)
diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml
index f13b5c078..d1028bfab 100644
--- a/src/bin/expect_tests/help_tests.ml
+++ b/src/bin/expect_tests/help_tests.ml
@@ -176,6 +176,10 @@ let%expect_test _ =
                SOURCE_FILE is the path to the smart contract file.
 
     OPTIONS
+           --disable-michelson-typechecking
+               disable Michelson typecking, this might produce ill-typed
+               Michelson code.
+
            --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
            (absent=human-readable)
                DISPLAY_FORMAT is the format that will be used by the CLI.
diff --git a/src/main/compile/of_michelson.ml b/src/main/compile/of_michelson.ml
index 3602a495e..93213152a 100644
--- a/src/main/compile/of_michelson.ml
+++ b/src/main/compile/of_michelson.ml
@@ -32,8 +32,8 @@ module Errors = struct
     error title_type_check_msg message
 end
 
-let build_contract : Compiler.compiled_expression -> Michelson.michelson result =
-  fun compiled ->
+let build_contract : ?disable_typecheck:bool -> Compiler.compiled_expression -> Michelson.michelson result =
+  fun ?(disable_typecheck= false) compiled ->
   let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_contract_inputs compiled.expr_ty in
   let%bind param_michelson =
     Trace.trace_tzresult_lwt (simple_error "Could not unparse parameter") @@
@@ -42,16 +42,19 @@ let build_contract : Compiler.compiled_expression -> Michelson.michelson result
     Trace.trace_tzresult_lwt (simple_error "Could not unparse storage") @@
     Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in
   let contract = Michelson.contract param_michelson storage_michelson compiled.expr in
-  let%bind res =
-    Trace.trace_tzresult_lwt (simple_error "Could not typecheck the code") @@
-    Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
-  match res with
-  | Type_checked  -> ok contract
-  | Err_parameter -> fail @@ Errors.bad_parameter contract ()
-  | Err_storage   -> fail @@ Errors.bad_storage contract ()
-  | Err_contract  -> fail @@ Errors.bad_contract contract ()
-  | Err_gas       -> fail @@ Errors.ran_out_of_gas ()
-  | Err_unknown   -> fail @@ Errors.unknown ()
+  if disable_typecheck then
+    ok contract
+  else
+    let%bind res =
+      Trace.trace_tzresult_lwt (simple_error "Could not typecheck the code") @@
+      Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
+    match res with
+    | Type_checked  -> ok contract
+    | Err_parameter -> fail @@ Errors.bad_parameter contract ()
+    | Err_storage   -> fail @@ Errors.bad_storage contract ()
+    | Err_contract  -> fail @@ Errors.bad_contract contract ()
+    | Err_gas       -> fail @@ Errors.ran_out_of_gas ()
+    | Err_unknown   -> fail @@ Errors.unknown ()
 
 type check_type = Check_parameter | Check_storage
 let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result =