CLI: No print source flag for large programs

src/client/embedded/alpha/client_proto_args.ml

@@ -48,7 +48,7 @@ let () =
     Data_encoding.(obj1 (req "parameter" string))
     (function Bad_endorsement_delay parameter -> Some parameter | _ -> None)
     (fun parameter -> Bad_endorsement_delay parameter)
-  
+
 
 let tez_sym =
   "\xEA\x9C\xA9"
@@ -69,14 +69,13 @@ let arg_arg =
     ~doc:"The argument passed to the contract's script, if needed."
     ~default:"Unit"
     string_parameter
-  
+
 let delegate_arg =
   arg
     ~parameter:"-delegate"
     ~doc:"Set the delegate of the contract.\
           Must be a known identity."
     string_parameter
-  
 
 let source_arg =
   arg
@@ -149,6 +148,12 @@ let endorsement_delay_arg =
          try return (int_of_string s)
          with _ -> fail (Bad_endorsement_delay s)))
 
+let no_print_source_flag =
+  switch
+    ~parameter:"-no-print-source"
+    ~doc:"Don't print the source code if an error is encountered.\
+          This should be enabled for extremely large programs"
+
 module Daemon = struct
   let baking_switch =
     switch

src/client/embedded/alpha/client_proto_args.mli

@@ -23,6 +23,8 @@ val free_baking_switch: (bool, Client_commands.context) arg
 val force_switch: (bool, Client_commands.context) arg
 val endorsement_delay_arg: (int, Client_commands.context) arg
 
+val no_print_source_flag : (bool, Client_commands.context) arg
+
 val tez_arg :
   default:string ->
   parameter:string ->

src/client/embedded/alpha/client_proto_context.ml

@@ -362,9 +362,9 @@ let commands () =
       end ;
 
     command ~group ~desc: "Launch a smart contract on the blockchain"
-      (args6
+      (args7
          fee_arg delegate_arg force_switch
-         delegatable_switch spendable_switch init_arg)
+         delegatable_switch spendable_switch init_arg no_print_source_flag)
       (prefixes [ "originate" ; "contract" ]
        @@ RawContractAlias.fresh_alias_param
          ~name: "new" ~desc: "name of the new contract"
@@ -382,7 +382,7 @@ let commands () =
          ~name:"prg" ~desc: "script of the account\n\
                              combine with -init if the storage type is not unit"
        @@ stop)
-      begin fun (fee, delegate, force, delegatable, spendable, init)
+      begin fun (fee, delegate, force, delegatable, spendable, init, no_print_source)
         neu (_, manager) balance (_, source) { expanded = code } cctxt ->
         check_contract cctxt neu >>=? fun () ->
         get_delegate_pkh cctxt delegate >>=? fun delegate ->
@@ -396,8 +396,8 @@ let commands () =
         | Error errs ->
             cctxt.warning "%a"
               (Michelson_v1_error_reporter.report_errors
-                 ~details: true
+                 ~details:(not no_print_source)
-                 ~show_source: true
+                 ~show_source: (not no_print_source)
                  ?parsed:None) errs >>= fun () ->
             cctxt.error "origination simulation failed"
         | Ok (oph, contract) ->
@@ -429,7 +429,7 @@ let commands () =
       end;
 
     command ~group ~desc: "transfer tokens"
-      (args3 fee_arg arg_arg force_switch)
+      (args4 fee_arg arg_arg force_switch no_print_source_flag)
       (prefixes [ "transfer" ]
        @@ tez_param
          ~name: "qty" ~desc: "amount taken from source"
@@ -440,7 +440,7 @@ let commands () =
        @@ ContractAlias.destination_param
          ~name: "dst" ~desc: "name/literal of the destination contract"
        @@ stop)
-      begin fun (fee, arg, force) amount (_, source) (_, destination) cctxt ->
+      begin fun (fee, arg, force, no_print_source) amount (_, source) (_, destination) cctxt ->
         get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
         transfer cctxt.rpc_config cctxt.config.block ~force:force
           ~source ~src_pk ~src_sk ~destination
@@ -449,7 +449,7 @@ let commands () =
             cctxt.warning "%a"
               (Michelson_v1_error_reporter.report_errors
                  ~details: false
-                 ~show_source: true
+                 ~show_source:(not no_print_source)
                  ?parsed:None) errs >>= fun () ->
             cctxt.error "transfer simulation failed"
         | Ok (oph, contracts) ->

src/client/embedded/alpha/client_proto_programs.ml

@@ -90,7 +90,7 @@ let commands () =
          return ()) ;
 
     command ~group ~desc: "ask the node to run a program"
-      (args2 trace_stack_switch amount_arg)
+      (args3 trace_stack_switch amount_arg no_print_source_flag)
       (prefixes [ "run" ; "program" ]
        @@ Program.source_param
        @@ prefixes [ "on" ; "storage" ]
@@ -100,13 +100,13 @@ let commands () =
        @@ Cli_entries.param ~name:"storage" ~desc:"the input data"
          data_parameter
        @@ stop)
-      (fun (trace_stack, amount) program storage input cctxt ->
+      (fun (trace_stack, amount, no_print_source) program storage input cctxt ->
          let open Data_encoding in
          let print_errors errs =
            cctxt.warning "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
-                ~show_source: true
+                ~show_source: (not no_print_source)
                 ~parsed:program) errs >>= fun () ->
            cctxt.error "error running program" >>= fun () ->
            return () in
@@ -142,11 +142,11 @@ let commands () =
                print_errors errs);
 
     command ~group ~desc: "ask the node to typecheck a program"
-      (args2 show_types_switch emacs_mode_switch)
+      (args3 show_types_switch emacs_mode_switch no_print_source_flag)
       (prefixes [ "typecheck" ; "program" ]
        @@ Program.source_param
        @@ stop)
-      (fun (show_types, emacs_mode) program cctxt ->
+      (fun (show_types, emacs_mode, no_print_source) program cctxt ->
          let open Data_encoding in
          Client_proto_rpcs.Helpers.typecheck_code
            cctxt.rpc_config cctxt.config.block program.expanded >>= fun res ->
@@ -177,12 +177,12 @@ let commands () =
                cctxt.warning "%a"
                  (Michelson_v1_error_reporter.report_errors
                     ~details: show_types
-                    ~show_source: true
+                    ~show_source: (not no_print_source)
                     ~parsed:program) errs >>= fun () ->
                cctxt.error "ill-typed program") ;
 
     command ~group ~desc: "ask the node to typecheck a data expression"
-      no_options
+      (args1 no_print_source_flag)
       (prefixes [ "typecheck" ; "data" ]
        @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
          data_parameter
@@ -190,7 +190,7 @@ let commands () =
        @@ Cli_entries.param ~name:"type" ~desc:"the expected type"
          data_parameter
        @@ stop)
-      (fun () data exp_ty cctxt ->
+      (fun no_print_source data exp_ty cctxt ->
          let open Data_encoding in
          Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
            cctxt.config.block (data.expanded, exp_ty.expanded) >>= function
@@ -201,7 +201,7 @@ let commands () =
              cctxt.warning "%a"
                (Michelson_v1_error_reporter.report_errors
                   ~details:false
-                  ~show_source: true
+                  ~show_source:(not no_print_source)
                   ?parsed:None) errs >>= fun () ->
              cctxt.error "ill-typed data") ;
 

src/client/embedded/alpha/michelson_v1_emacs.ml

@@ -107,7 +107,7 @@ let report_errors ppf (parsed, errs) =
           let message =
             Format.asprintf "%a"
               (Michelson_v1_error_reporter.report_errors
-                 ~details: false ~show_source: false ~parsed)
+                 ~details:false ~show_source:false ~parsed)
               errs in
           let { start = { point = s } ; stop = { point = e } } =
             let oloc = List.assoc loc parsed.unexpansion_table in

src/proto/alpha/script_ir_translator.ml

@@ -1173,9 +1173,6 @@ and parse_instr
         check_item_ty elt pelt loc I_REDUCE 2 3 >>=? fun (Eq _) ->
         check_item_ty init r loc I_REDUCE 3 3 >>=? fun (Eq _) ->
         return (typed loc (List_reduce, Item_t (r, rest, instr_annot)))
-    | Prim (loc, I_SIZE, [], instr_annot),
-      Item_t (List_t _, rest, _) ->
-        return (typed loc (List_size, Item_t (Nat_t, rest, instr_annot)))
     | Prim (loc, I_ITER, [ body ], instr_annot),
       Item_t (List_t elt, rest, _) ->
         check_kind [ Seq_kind ] body >>=? fun () ->