From 32a466556efc0ecad6d52b905d04e52fe914c84d Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Mon, 13 Nov 2017 14:29:28 +0100 Subject: [PATCH] Jbuilder: use --dev option --- Makefile | 6 +-- src/client/client_generic_rpcs.ml | 6 +-- src/client/client_helpers.ml | 1 - src/client/client_keys.ml | 2 +- .../embedded/alpha/client_baking_daemon.ml | 1 - .../alpha/client_baking_endorsement.ml | 1 - .../embedded/alpha/client_baking_forge.ml | 5 +-- .../embedded/alpha/client_baking_main.ml | 2 - .../alpha/client_baking_operations.ml | 2 - .../alpha/client_baking_revelation.ml | 3 -- .../embedded/alpha/client_proto_args.ml | 4 +- .../embedded/alpha/client_proto_contracts.ml | 1 - .../embedded/alpha/client_proto_nonces.ml | 2 - .../embedded/alpha/client_proto_programs.ml | 5 --- .../embedded/alpha/client_proto_rpcs.ml | 2 - src/client/embedded/alpha/jbuild | 4 +- .../embedded/alpha/michelson_macros.mli | 2 - .../alpha/michelson_v1_error_reporter.ml | 2 +- .../embedded/alpha/michelson_v1_parser.ml | 2 +- .../embedded/alpha/michelson_v1_parser.mli | 28 +++++++------ src/client/embedded/genesis/jbuild | 4 +- src/client/jbuild | 3 +- src/client_main.ml | 1 - src/compiler/jbuild | 3 +- src/compiler/native.ml | 5 +-- src/environment/jbuild | 2 +- src/environment/sigs_packer/jbuild | 3 +- src/environment/sigs_packer/sigs_packer.ml | 14 +++---- src/environment/v1/tezos_data.mli | 6 +-- src/environment/v1/z.mli | 2 + src/jbuild | 9 +++-- src/micheline/jbuild | 2 +- src/micheline/micheline_printer.ml | 1 - src/micheline/micheline_printer.mli | 1 - src/minutils/compare.ml | 2 +- src/minutils/data_encoding.ml | 36 ++++++----------- src/minutils/jbuild | 2 +- src/minutils/utils.ml | 4 +- src/minutils/utils.mli | 1 + src/node/db/context.ml | 39 ++++++++----------- src/node/db/jbuild | 3 +- src/node/db/persist.ml | 18 ++++----- src/node/db/persist.mli | 3 -- src/node/db/raw_store.ml | 1 - src/node/db/store.ml | 2 - src/node/db/store_helpers.ml | 2 +- src/node/main/jbuild | 4 +- src/node/main/node_config_file.ml | 4 +- src/node/main/node_config_file.mli | 2 - src/node/main/node_run_command.ml | 5 +-- src/node/main/node_shared_arg.ml | 3 +- src/node/main/node_shared_arg.mli | 2 - src/node/net/jbuild | 3 +- src/node/net/p2p.ml | 9 ++--- src/node/net/p2p_connection.ml | 15 +++---- src/node/net/p2p_connection_pool.ml | 10 ++--- src/node/net/p2p_connection_pool.mli | 5 ++- src/node/net/p2p_connection_pool_types.ml | 1 - src/node/net/p2p_discovery.ml | 1 - src/node/net/p2p_io_scheduler.ml | 6 +-- src/node/net/p2p_maintenance.ml | 4 +- src/node/net/p2p_types.ml | 2 - src/node/net/p2p_welcome.ml | 4 +- src/node/shell/chain.ml | 2 +- src/node/shell/distributed_db.ml | 19 +-------- src/node/shell/distributed_db_functors.ml | 1 - src/node/shell/jbuild | 3 +- src/node/shell/node.ml | 2 +- src/node/shell/prevalidator.ml | 6 +-- src/node/shell/validator.ml | 7 +--- src/node/updater/jbuild | 3 +- src/proto/alpha/jbuild | 8 ++-- src/proto/demo/jbuild | 6 +-- src/proto/genesis/jbuild | 9 +++-- src/utils/base58.ml | 4 +- src/utils/cli_entries.ml | 11 +++--- src/utils/cli_entries.mli | 4 ++ src/utils/crypto_box.ml | 3 -- src/utils/error_monad.ml | 4 +- src/utils/hash.ml | 4 -- src/utils/jbuild | 2 +- src/utils/lwt_dropbox.ml | 2 +- src/utils/lwt_pipe.ml | 6 +-- src/utils/lwt_utils.ml | 2 +- src/utils/time.ml | 1 - test/lib/jbuild | 3 +- test/lib/node_helpers.ml | 2 +- test/p2p/jbuild | 4 +- test/p2p/test_p2p_connection.ml | 1 - test/proto_alpha/jbuild | 3 +- test/proto_alpha/proto_alpha_helpers.mli | 1 + test/shell/jbuild | 4 +- test/shell/test_context.ml | 2 +- test/shell/test_store.ml | 5 +-- test/utils/jbuild | 4 +- test/utils/test_data_encoding.ml | 1 - test/utils/test_merkle.ml | 1 - test/utils/test_stream_data_encoding.ml | 34 ++++++++-------- test/utils/test_utils.ml | 1 - 99 files changed, 210 insertions(+), 295 deletions(-) diff --git a/Makefile b/Makefile index 6ec771893..0303d0c67 100644 --- a/Makefile +++ b/Makefile @@ -1,15 +1,15 @@ all: - @jbuilder build tezos.install + @jbuilder build tezos.install --dev @cp _build/default/src/node_main.exe tezos-node @cp _build/default/src/client_main.exe tezos-client @cp _build/default/src/compiler_main.exe tezos-protocol-compiler doc-html: - @jbuilder build @doc + @jbuilder build @doc --dev build-test: - @jbuilder build @buildtest + @jbuilder build @buildtest --dev test: @jbuilder runtest diff --git a/src/client/client_generic_rpcs.ml b/src/client/client_generic_rpcs.ml index b8d996eb5..3fb9ce806 100644 --- a/src/client/client_generic_rpcs.ml +++ b/src/client/client_generic_rpcs.ml @@ -16,7 +16,6 @@ open Json_schema (*-- Assisted, schema directed input fill in --------------------------------*) -exception Erroneous_construct exception Unsupported_construct type input = { @@ -132,7 +131,7 @@ let editor_fill_in schema = random_fill_in schema >>= function | Error msg -> Lwt.return (Error msg) | Ok json -> - Lwt_io.(with_file Output tmp (fun fp -> + Lwt_io.(with_file ~mode:Output tmp (fun fp -> write_line fp (Data_encoding_ezjsonm.to_string json))) >>= fun () -> edit () and edit () = @@ -160,7 +159,7 @@ let editor_fill_in schema = Lwt.return (Error msg) and reread () = (* finally reread the file *) - Lwt_io.(with_file Input tmp (fun fp -> read fp)) >>= fun text -> + Lwt_io.(with_file ~mode:Input tmp (fun fp -> read fp)) >>= fun text -> match Data_encoding_ezjsonm.from_string text with | Ok r -> Lwt.return (Ok r) | Error msg -> Lwt.return (Error (Printf.sprintf "bad input: %s" msg)) @@ -350,7 +349,6 @@ let call_with_json url json (cctxt: Client_commands.context) = "Failed to parse the provided json: %s\n%!" err | Ok json -> - let open RPC.Description in Client_rpcs.get_json cctxt.rpc_config `POST args json >>=? fun json -> cctxt.message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () -> diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index 326f6036f..c233a1168 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -8,7 +8,6 @@ (**************************************************************************) open Client_commands -open Client_config let unique_switch = Cli_entries.switch diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 814972d6c..69b6d853e 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -162,7 +162,7 @@ let alias_keys cctxt name = let rec find_key = function | [] -> return None | (key_name, pkh) :: tl -> - if String.(key_name = name) + if key_name = name then Public_key.find_opt cctxt name >>=? fun pkm -> Secret_key.find_opt cctxt name >>=? fun pks -> diff --git a/src/client/embedded/alpha/client_baking_daemon.ml b/src/client/embedded/alpha/client_baking_daemon.ml index 614e887e9..d7e156ec2 100644 --- a/src/client/embedded/alpha/client_baking_daemon.ml +++ b/src/client/embedded/alpha/client_baking_daemon.ml @@ -8,7 +8,6 @@ (**************************************************************************) open Client_commands -open Logging.Client.Baking let run cctxt ?max_priority ~delay ?min_date delegates ~endorsement ~denunciation ~baking = (* TODO really detach... *) diff --git a/src/client/embedded/alpha/client_baking_endorsement.ml b/src/client/embedded/alpha/client_baking_endorsement.ml index aceed1f3f..5d829e3de 100644 --- a/src/client/embedded/alpha/client_baking_endorsement.ml +++ b/src/client/embedded/alpha/client_baking_endorsement.ml @@ -9,7 +9,6 @@ open Logging.Client.Endorsement open Client_commands -open Cli_entries module Ed25519 = Environment.Ed25519 diff --git a/src/client/embedded/alpha/client_baking_forge.ml b/src/client/embedded/alpha/client_baking_forge.ml index b77d6821f..f2a997d72 100644 --- a/src/client/embedded/alpha/client_baking_forge.ml +++ b/src/client/embedded/alpha/client_baking_forge.ml @@ -20,7 +20,7 @@ let generate_seed_nonce () = | Error _ -> assert false | Ok nonce -> nonce -let rec forge_block_header +let forge_block_header cctxt block delegate_sk shell priority seed_nonce_hash = Client_proto_rpcs.Constants.stamp_threshold cctxt block >>=? fun stamp_threshold -> @@ -620,6 +620,3 @@ let create lwt_log_info "Starting baking daemon" >>= fun () -> worker_loop () >>= fun () -> return () - -(* FIXME bug in ocamldep ?? *) -open Level diff --git a/src/client/embedded/alpha/client_baking_main.ml b/src/client/embedded/alpha/client_baking_main.ml index 6039da0ab..919d1ee6f 100644 --- a/src/client/embedded/alpha/client_baking_main.ml +++ b/src/client/embedded/alpha/client_baking_main.ml @@ -7,9 +7,7 @@ (* *) (**************************************************************************) -open Cli_entries open Client_commands -open Client_proto_contracts let mine_block cctxt block ?force ?max_priority ?(free_baking=false) ?src_sk delegate = diff --git a/src/client/embedded/alpha/client_baking_operations.ml b/src/client/embedded/alpha/client_baking_operations.ml index 598bfbfc6..2aadf97b4 100644 --- a/src/client/embedded/alpha/client_baking_operations.ml +++ b/src/client/embedded/alpha/client_baking_operations.ml @@ -9,8 +9,6 @@ module Ed25519 = Environment.Ed25519 -open Operation - type operation = { hash: Operation_hash.t ; content: Operation.t option diff --git a/src/client/embedded/alpha/client_baking_revelation.ml b/src/client/embedded/alpha/client_baking_revelation.ml index 6b21b93ac..33aaf857e 100644 --- a/src/client/embedded/alpha/client_baking_revelation.ml +++ b/src/client/embedded/alpha/client_baking_revelation.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Cli_entries open Tezos_context let inject_seed_nonce_revelation rpc_config block ?force ?async nonces = @@ -22,8 +21,6 @@ let inject_seed_nonce_revelation rpc_config block ?force ?async nonces = Client_node_rpcs.inject_operation rpc_config ?force ?async bytes >>=? fun oph -> return oph -type Error_monad.error += Bad_revelation - let forge_seed_nonce_revelation (cctxt: Client_commands.context) block ?(force = false) nonces = diff --git a/src/client/embedded/alpha/client_proto_args.ml b/src/client/embedded/alpha/client_proto_args.ml index 229e51568..7ced28f34 100644 --- a/src/client/embedded/alpha/client_proto_args.ml +++ b/src/client/embedded/alpha/client_proto_args.ml @@ -115,8 +115,8 @@ let tez_arg ~default ~parameter ~doc = let tez_param ~name ~desc next = Cli_entries.param - name - (desc ^ " in \xEA\x9C\xA9\n" ^ tez_format) + ~name + ~desc:(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format) (tez_parameter name) next diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index a890f4dd7..32143eba0 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -134,7 +134,6 @@ let get_manager cctxt block source = | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source let get_delegate cctxt block source = - let open Client_keys in match Contract.is_default source with | Some hash -> return hash | None -> diff --git a/src/client/embedded/alpha/client_proto_nonces.ml b/src/client/embedded/alpha/client_proto_nonces.ml index ac39bded1..be13dd4c5 100644 --- a/src/client/embedded/alpha/client_proto_nonces.ml +++ b/src/client/embedded/alpha/client_proto_nonces.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Cli_entries - (* TODO locking... *) type t = (Block_hash.t * Nonce.t) list diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index 77986e755..1c8e99a86 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -101,7 +101,6 @@ let commands () = data_parameter @@ stop) (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 @@ -147,7 +146,6 @@ let commands () = @@ Program.source_param @@ stop) (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 -> if emacs_mode then @@ -191,7 +189,6 @@ let commands () = data_parameter @@ stop) (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 | Ok () -> @@ -214,7 +211,6 @@ let commands () = data_parameter @@ stop) (fun () data cctxt -> - let open Data_encoding in Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config cctxt.config.block (data.expanded) >>= function | Ok hash -> @@ -237,7 +233,6 @@ let commands () = @@ Client_keys.Secret_key.alias_param @@ stop) (fun () data (_, key) cctxt -> - let open Data_encoding in Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config cctxt.config.block (data.expanded) >>= function | Ok hash -> diff --git a/src/client/embedded/alpha/client_proto_rpcs.ml b/src/client/embedded/alpha/client_proto_rpcs.ml index a058edbd3..1e228d535 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.ml +++ b/src/client/embedded/alpha/client_proto_rpcs.ml @@ -185,8 +185,6 @@ module Helpers = struct module Forge = struct - open Operation - module Manager = struct let operations cctxt block ~net_id ~branch ~source ?sourcePubKey ~counter ~fee operations = diff --git a/src/client/embedded/alpha/jbuild b/src/client/embedded/alpha/jbuild index 5ab899be8..660e2984b 100644 --- a/src/client/embedded/alpha/jbuild +++ b/src/client/embedded/alpha/jbuild @@ -2,11 +2,13 @@ (library ((name client_embedded_alpha) + (public_name tezos.client.embedded.alpha) (libraries (tezos_embedded_protocol_alpha tezos_embedded_raw_protocol_alpha client_lib)) (library_flags (:standard -linkall)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/client/embedded/alpha/michelson_macros.mli b/src/client/embedded/alpha/michelson_macros.mli index 2d2efef04..a29912c0b 100644 --- a/src/client/embedded/alpha/michelson_macros.mli +++ b/src/client/embedded/alpha/michelson_macros.mli @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Micheline - type 'l node = ('l, string) Micheline.node val expand : 'l node -> 'l node diff --git a/src/client/embedded/alpha/michelson_v1_error_reporter.ml b/src/client/embedded/alpha/michelson_v1_error_reporter.ml index bb3c9edeb..5ba52b922 100644 --- a/src/client/embedded/alpha/michelson_v1_error_reporter.ml +++ b/src/client/embedded/alpha/michelson_v1_error_reporter.ml @@ -17,7 +17,7 @@ let print_ty (type t) ppf (annot, (ty : t ty)) = |> Micheline.strip_locations |> Michelson_v1_printer.print_expr_unwrapped ppf -let rec print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) = +let print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) = let rec loop : type t. int -> Format.formatter -> t stack_ty -> unit = fun depth ppf -> function diff --git a/src/client/embedded/alpha/michelson_v1_parser.ml b/src/client/embedded/alpha/michelson_v1_parser.ml index 784aa1074..77db678f1 100644 --- a/src/client/embedded/alpha/michelson_v1_parser.ml +++ b/src/client/embedded/alpha/michelson_v1_parser.ml @@ -59,7 +59,7 @@ let parse_toplevel ?check source = | [ ast ] -> ast | asts -> let start = min_point asts and stop = max_point asts in - Seq (Michelson_macros.{ start ; stop }, asts, None) in + Seq ({ start ; stop }, asts, None) in expand_all source ast let parse_expression ?check source = diff --git a/src/client/embedded/alpha/michelson_v1_parser.mli b/src/client/embedded/alpha/michelson_v1_parser.mli index fc3f69c0d..8ea5ed18f 100644 --- a/src/client/embedded/alpha/michelson_v1_parser.mli +++ b/src/client/embedded/alpha/michelson_v1_parser.mli @@ -9,23 +9,21 @@ (** The result of parsing and expanding a Michelson V1 script or data. *) type parsed = - { source : - (** The original source code. *) - string ; - unexpanded : - (** Original expression with macros. *) - string Micheline.canonical ; - expanded : - (** Expression with macros fully expanded. *) - Script.expr ; + { + source : string ; + (** The original source code. *) + unexpanded : string Micheline.canonical ; + (** Original expression with macros. *) + expanded : Script.expr ; + (** Expression with macros fully expanded. *) expansion_table : - (** Associates unexpanded nodes to their parsing locations and - the nodes expanded from it in the expanded expression. *) (int * (Micheline_parser.location * int list)) list ; - unexpansion_table : - (** Associates an expanded node to its source in the unexpanded - expression. *) - (int * int) list } + (** Associates unexpanded nodes to their parsing locations and + the nodes expanded from it in the expanded expression. *) + unexpansion_table : (int * int) list ; + (** Associates an expanded node to its source in the unexpanded + expression. *) + } val parse_toplevel : ?check:bool -> string -> parsed tzresult val parse_expression : ?check:bool -> string -> parsed tzresult diff --git a/src/client/embedded/genesis/jbuild b/src/client/embedded/genesis/jbuild index eadc94883..0bd25a4e8 100644 --- a/src/client/embedded/genesis/jbuild +++ b/src/client/embedded/genesis/jbuild @@ -2,12 +2,14 @@ (library ((name client_embedded_genesis) + (public_name tezos.client.embedded.genesis) (libraries (tezos_embedded_raw_protocol_genesis tezos_embedded_protocol_genesis tezos_protocol_environment_alpha client_lib)) (library_flags (:standard -linkall)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/client/jbuild b/src/client/jbuild index 4fbfe30ac..076a5435a 100644 --- a/src/client/jbuild +++ b/src/client/jbuild @@ -10,7 +10,8 @@ node_db node_updater tezos_protocol_compiler)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/client_main.ml b/src/client_main.ml index d90bf9889..af1eb0010 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -9,7 +9,6 @@ (* Tezos Command line interface - Main Program *) -open Lwt.Infix open Client_commands open Error_monad diff --git a/src/compiler/jbuild b/src/compiler/jbuild index d93fcb45a..8bc665d09 100644 --- a/src/compiler/jbuild +++ b/src/compiler/jbuild @@ -21,7 +21,8 @@ ocplib-endian ocplib-ocamlres unix)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -opaque -open Error_monad -open Hash diff --git a/src/compiler/native.ml b/src/compiler/native.ml index ab0426234..22a9c1a50 100644 --- a/src/compiler/native.ml +++ b/src/compiler/native.ml @@ -53,7 +53,6 @@ let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t = (* Set hook *) let () = - let open Env.Persistent_signature in Env.Persistent_signature.load := (fun ~unit_name -> try Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name)) @@ -154,12 +153,12 @@ let hash_file file = let buf = BytesLabels.create buflen in let fd = Unix.openfile file [Unix.O_RDONLY] 0o600 in let state = init ~size:32 () in - let rec loop () = + let loop () = match Unix.read fd buf 0 buflen with | 0 -> () | nb_read -> Bytes.update state @@ - if nb_read = buflen then buf else BytesLabels.sub buf 0 nb_read + if nb_read = buflen then buf else BytesLabels.sub buf ~pos:0 ~len:nb_read in loop () ; Unix.close fd ; diff --git a/src/environment/jbuild b/src/environment/jbuild index 65c8b7501..2838c3ad3 100644 --- a/src/environment/jbuild +++ b/src/environment/jbuild @@ -52,5 +52,5 @@ (library ((name tezos_protocol_environment_sigs) (public_name tezos.protocol_environment.sigs) - (flags (:standard -nopervasives)) + (flags (:standard -safe-string -w -9-32 -nopervasives)) (modules ("V1")))) diff --git a/src/environment/sigs_packer/jbuild b/src/environment/sigs_packer/jbuild index d5cc59a0e..705c140e0 100644 --- a/src/environment/sigs_packer/jbuild +++ b/src/environment/sigs_packer/jbuild @@ -2,5 +2,6 @@ (executable ((name sigs_packer) - (public_name tezos-protocol-environment-sigs-packer))) + (public_name tezos-protocol-environment-sigs-packer) + (flags (:standard -w -9-32 -safe-string)))) diff --git a/src/environment/sigs_packer/sigs_packer.ml b/src/environment/sigs_packer/sigs_packer.ml index 91f891a8d..cd92cd89e 100644 --- a/src/environment/sigs_packer/sigs_packer.ml +++ b/src/environment/sigs_packer/sigs_packer.ml @@ -14,7 +14,7 @@ let dump_file oc file = let rec loop () = let len = input ic buf 0 buflen in if len <> 0 then begin - Printf.fprintf oc "%s" (if len = buflen then buf else Bytes.sub buf 0 len) ; + Printf.fprintf oc "%s" (Bytes.to_string (if len = buflen then buf else Bytes.sub buf 0 len)) ; loop () end in @@ -32,15 +32,15 @@ let include_mli oc file = let unit = String.capitalize_ascii (Filename.chop_extension (Filename.basename file)) in - Printf.fprintf stdout "module %s : sig\n" unit ; - Printf.fprintf stdout "# 1 %S\n" file ; - dump_file stdout file ; - Printf.fprintf stdout "end\n" ; + Printf.fprintf oc "module %s : sig\n" unit ; + Printf.fprintf oc "# 1 %S\n" file ; + dump_file oc file ; + Printf.fprintf oc "end\n" ; if unit = "Result" then - Printf.fprintf stdout + Printf.fprintf oc "type ('a, 'b) result = ('a, 'b) Result.result = \ \ Ok of 'a | Error of 'b\n" ; - if List.mem unit opened_modules then Printf.fprintf stdout "open %s\n" unit + if List.mem unit opened_modules then Printf.fprintf oc "open %s\n" unit let () = Printf.fprintf stdout "module type T = sig\n" ; diff --git a/src/environment/v1/tezos_data.mli b/src/environment/v1/tezos_data.mli index 0f88b57e7..076e57458 100644 --- a/src/environment/v1/tezos_data.mli +++ b/src/environment/v1/tezos_data.mli @@ -95,11 +95,11 @@ module Protocol : sig (** An OCaml source component of a protocol implementation. *) and component = { - (** The OCaml module name. *) + (* The OCaml module name. *) name : string ; - (** The OCaml interface source code *) + (* The OCaml interface source code *) interface : string option ; - (** The OCaml source code *) + (* The OCaml source code *) implementation : string ; } diff --git a/src/environment/v1/z.mli b/src/environment/v1/z.mli index 69facbc50..000eb61a7 100644 --- a/src/environment/v1/z.mli +++ b/src/environment/v1/z.mli @@ -64,11 +64,13 @@ val of_string: string -> t external to_int64: t -> int64 = "ml_z_to_int64" (** Converts to a 64-bit integer. May raise [Overflow]. *) + external of_int64: int64 -> t = "ml_z_of_int64" (** Converts from a 64-bit integer. *) external to_int: t -> int = "ml_z_to_int" (** Converts to a base integer. May raise an [Overflow]. *) + external of_int: int -> t = "ml_z_of_int" [@@ noalloc] (** Converts from a base integer. *) diff --git a/src/jbuild b/src/jbuild index 0fd5cfbae..e94b4e36f 100644 --- a/src/jbuild +++ b/src/jbuild @@ -4,7 +4,8 @@ ((name compiler_main) (public_name tezos-protocol-compiler) (libraries (tezos_protocol_compiler)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -linkall)) (modules (Compiler_main)))) @@ -15,7 +16,8 @@ tezos_embedded_protocol_genesis tezos_embedded_protocol_demo tezos_embedded_protocol_alpha)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -linkall)) (modules (Node_main)))) @@ -23,6 +25,7 @@ ((name client_main) (public_name tezos-client) (libraries (lwt utils client_lib client_embedded_genesis client_embedded_alpha)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -linkall)) (modules (Client_main)))) diff --git a/src/micheline/jbuild b/src/micheline/jbuild index bdc7f848f..648cb66e9 100644 --- a/src/micheline/jbuild +++ b/src/micheline/jbuild @@ -11,7 +11,7 @@ minutils utils )) - (flags (:standard -w +27-30-40@8)) + (flags (:standard -w -9+27-30-32-40@8 -safe-string)) (wrapped false))) diff --git a/src/micheline/micheline_printer.ml b/src/micheline/micheline_printer.ml index 4929ec452..054b4c8a8 100644 --- a/src/micheline/micheline_printer.ml +++ b/src/micheline/micheline_printer.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Error_monad open Micheline type location = { comment : string option } diff --git a/src/micheline/micheline_printer.mli b/src/micheline/micheline_printer.mli index 2ba5a705c..3a5516970 100644 --- a/src/micheline/micheline_printer.mli +++ b/src/micheline/micheline_printer.mli @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Error_monad open Micheline val print_string : Format.formatter -> string -> unit diff --git a/src/minutils/compare.ml b/src/minutils/compare.ml index d63cd9cd9..fd96fe1e4 100644 --- a/src/minutils/compare.ml +++ b/src/minutils/compare.ml @@ -159,7 +159,7 @@ end module Option(P : S) = struct type t = P.t option - let rec compare xs ys = + let compare xs ys = match xs, ys with | None, None -> 0 | None, _ -> -1 diff --git a/src/minutils/data_encoding.ml b/src/minutils/data_encoding.ml index a4916ae1c..99ca34746 100644 --- a/src/minutils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Utils - type json = [ `O of (string * json) list | `Bool of bool @@ -17,10 +15,6 @@ type json = | `Null | `String of string ] -and document = - [ `O of (string * json) list - | `A of json list ] - type json_schema = Json_schema.schema exception No_case_matched @@ -172,8 +166,7 @@ and 'a t = { type 'a encoding = 'a t -let rec classify : type a l. a t -> Kind.t = fun e -> - let open Kind in +let rec classify : type a. a t -> Kind.t = fun e -> match e.encoding with (* Fixed *) | Null -> `Fixed 0 @@ -222,8 +215,6 @@ module Json = struct exception Parse_error of string - type nonrec json = json - let wrap_error f = fun str -> try f str @@ -292,7 +283,7 @@ module Json = struct | _ -> e and lift_union_in_pair - : type a a_l b b_l. pair_builder -> Kind.t -> a t -> b t -> (a * b) t + : type a b. pair_builder -> Kind.t -> a t -> b t -> (a * b) t = fun b p e1 e2 -> match lift_union e1, lift_union e2 with | e1, { encoding = Union (_kind, tag, cases) } -> @@ -323,7 +314,7 @@ module Json = struct cases) | e1, e2 -> b.build p e1 e2 - let rec json : type a l. a desc -> a Json_encoding.encoding = + let rec json : type a. a desc -> a Json_encoding.encoding = let open Json_encoding in function | Null -> null @@ -362,19 +353,19 @@ module Json = struct | Delayed f -> get_json (f ()) and field_json - : type a l. a field -> a Json_encoding.field = + : type a. a field -> a Json_encoding.field = let open Json_encoding in function | Req (name, e) -> req name (get_json e) | Opt (_, name, e) -> opt name (get_json e) | Dft (name, e, d) -> dft name (get_json e) d - and case_json : type a l. a case -> a Json_encoding.case = + and case_json : type a. a case -> a Json_encoding.case = let open Json_encoding in function | Case { encoding = e ; proj ; inj ; _ } -> case (get_json e) proj inj - and get_json : type a l. a t -> a Json_encoding.encoding = fun e -> + and get_json : type a. a t -> a Json_encoding.encoding = fun e -> match e.json_encoding with | None -> let json_encoding = json (lift_union e).encoding in @@ -459,7 +450,7 @@ module Encoding = struct let array e = dynamic_size (Variable.array e) let list e = dynamic_size (Variable.list e) - let conv (type l) proj inj ?schema encoding = + let conv proj inj ?schema encoding = make @@ Conv { proj ; inj ; encoding ; schema } let string_enum l = dynamic_size (Variable.string_enum l) @@ -546,7 +537,7 @@ module Encoding = struct raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1) let merge_objs o1 o2 = - let rec is_obj : type a l. a t -> bool = fun e -> + let rec is_obj : type a. a t -> bool = fun e -> match e.encoding with | Obj _ -> true | Objs _ (* by construction *) -> true @@ -587,7 +578,7 @@ module Encoding = struct raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1) let merge_tups t1 t2 = - let rec is_tup : type a l. a t -> bool = fun e -> + let rec is_tup : type a. a t -> bool = fun e -> match e.encoding with | Tup _ -> true | Tups _ (* by construction *) -> true @@ -745,7 +736,6 @@ module Binary = struct } let rec length : type x. x t -> x -> int = fun e -> - let open Kind in match e.encoding with (* Fixed *) | Null -> fun _ -> 0 @@ -780,7 +770,7 @@ let rec length : type x. x t -> x -> int = fun e -> | Case { tag = None } -> None | Case { encoding = e ; proj ; tag = Some _ } -> let length v = tag_size sz + length e v in - Some (fun v -> Utils.map_option length (proj v)) in + Some (fun v -> Utils.map_option ~f:length (proj v)) in apply (Utils.filter_map case_length cases) | Mu (`Dynamic, _name, self) -> fun v -> length (self e) v @@ -953,8 +943,7 @@ let rec length : type x. x t -> x -> int = fun e -> end let rec write_rec - : type a l. a t -> a -> MBytes.t -> int -> int = fun e -> - let open Kind in + : type a. a t -> a -> MBytes.t -> int -> int = fun e -> let open Writer in match e.encoding with | Null -> (fun () _buf ofs -> ofs) @@ -1159,8 +1148,7 @@ let rec length : type x. x t -> x -> int = fun e -> end - let rec read_rec : type a l. a t-> MBytes.t -> int -> int -> int * a = fun e -> - let open Kind in + let rec read_rec : type a. a t-> MBytes.t -> int -> int -> int * a = fun e -> let open Reader in match e.encoding with | Null -> (fun _buf ofs _len -> ofs, ()) diff --git a/src/minutils/jbuild b/src/minutils/jbuild index d54c5b4b7..08b51baed 100644 --- a/src/minutils/jbuild +++ b/src/minutils/jbuild @@ -7,5 +7,5 @@ lwt ocplib-json-typed.bson ocplib-resto.directory)) - (flags (:standard -w +27-30-40@8)) + (flags (:standard -w -9+27-30-32-40@8 -safe-string)) (wrapped false))) diff --git a/src/minutils/utils.ml b/src/minutils/utils.ml index e7111acc8..bd3e9836f 100644 --- a/src/minutils/utils.ml +++ b/src/minutils/utils.ml @@ -147,7 +147,7 @@ let rec remove_elem_from_list nb = function | l when nb <= 0 -> l | _ :: tl -> remove_elem_from_list (nb - 1) tl -let rec split_list_at n l = +let split_list_at n l = let rec split n acc = function | [] -> List.rev acc, [] | l when n <= 0 -> List.rev acc, l @@ -196,7 +196,7 @@ let write_file ?(bin=false) fn contents = let (<<) g f = fun a -> g (f a) -let rec (--) i j = +let (--) i j = let rec loop acc j = if j < i then acc else loop (j :: acc) (pred j) in loop [] j diff --git a/src/minutils/utils.mli b/src/minutils/utils.mli index af1e62e47..5bbd3abd0 100644 --- a/src/minutils/utils.mli +++ b/src/minutils/utils.mli @@ -62,6 +62,7 @@ val filter_map: ('a -> 'b option) -> 'a list -> 'b list (** [list_rev_sub l n] is [List.rev l] capped to max [n] elements *) val list_rev_sub : 'a list -> int -> 'a list + (** [list_sub l n] is [l] capped to max [n] elements *) val list_sub: 'a list -> int -> 'a list diff --git a/src/node/db/context.ml b/src/node/db/context.ml index a872b31af..732936a71 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -10,7 +10,6 @@ (** Tezos - Versioned (key x value) store (over Irmin) *) open Hash -open Logging.Db module IrminPath = Irmin.Path.String_list @@ -95,9 +94,6 @@ let checkout_exn index key = | Some p -> Lwt.return p -exception Preexistent_context of Block_hash.t -exception Empty_head of Block_hash.t - let raw_commit ~time ~message context = let info = Irmin.Info.v ~date:(Time.to_seconds time) ~author:"Tezos" message in @@ -116,30 +112,29 @@ let commit ~time ~message context = Lwt_utils.Idle_waiter.force_idle context.index.repack_scheduler begin fun () -> - lwt_debug "begin git repack" >>= fun () -> - let command = - "git", - [| "git" ; "-C" ; context.index.path ; - "repack" ; "-a" ; "-d" |] in - let t0 = Unix.gettimeofday () in - Lwt_process.exec - ~stdout: `Dev_null ~stderr: `Dev_null - command >>= fun res -> - let dt = Unix.gettimeofday () -. t0 in - match res with - | WEXITED 0 -> - lwt_log_notice "git repack complete in %0.2f sec" dt - | WEXITED code | WSTOPPED code | WSIGNALED code -> - lwt_log_error "git repack failed with code %d after %0.2f sec" - code dt + let open Logging.Db in + lwt_debug "begin git repack" >>= fun () -> + let command = + "git", + [| "git" ; "-C" ; context.index.path ; + "repack" ; "-a" ; "-d" |] in + let t0 = Unix.gettimeofday () in + Lwt_process.exec + ~stdout: `Dev_null ~stderr: `Dev_null + command >>= fun res -> + let dt = Unix.gettimeofday () -. t0 in + match res with + | WEXITED 0 -> + lwt_log_notice "git repack complete in %0.2f sec" dt + | WEXITED code | WSTOPPED code | WSIGNALED code -> + lwt_log_error "git repack failed with code %d after %0.2f sec" + code dt end end >>= fun () -> Lwt.return commit (*-- Generic Store Primitives ------------------------------------------------*) -type key = string list - let data_key key = "data" :: key let undata_key = function | "data" :: key -> key diff --git a/src/node/db/jbuild b/src/node/db/jbuild index 53039437e..5d96ea7c3 100644 --- a/src/node/db/jbuild +++ b/src/node/db/jbuild @@ -4,7 +4,8 @@ ((name node_db) (public_name tezos.node.db) (libraries (utils minutils leveldb irmin irmin-unix)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/node/db/persist.ml b/src/node/db/persist.ml index a0024256e..b5b4b800a 100644 --- a/src/node/db/persist.ml +++ b/src/node/db/persist.ml @@ -121,7 +121,6 @@ module MakeBytesStore type t = S.t type key = K.t - type value = MBytes.t let to_path k = let suffix = K.to_path k in @@ -228,8 +227,8 @@ module MakePersistentSet | true -> dig K.length K.prefix x | false -> Lwt.return x - let iter c ~f = fold c () (fun x () -> f x) - let elements c = fold c [] (fun p xs -> Lwt.return (p :: xs)) + let iter c ~f = fold c () ~f:(fun x () -> f x) + let elements c = fold c [] ~f:(fun p xs -> Lwt.return (p :: xs)) end @@ -239,7 +238,7 @@ module MakeBufferedPersistentSet include MakePersistentSet(S)(K) let read c = - fold c Set.empty (fun p set -> Lwt.return (Set.add p set)) + fold c Set.empty ~f:(fun p set -> Lwt.return (Set.add p set)) let write c set = S.set c inited_key empty >>= fun c -> @@ -307,8 +306,8 @@ module MakePersistentMap | true -> dig K.length K.prefix x | false -> Lwt.return x - let iter c ~f = fold c () (fun k v () -> f k v) - let bindings c = fold c [] (fun k v acc -> Lwt.return ((k, v) :: acc)) + let iter c ~f = fold c () ~f:(fun k v () -> f k v) + let bindings c = fold c [] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc)) end @@ -317,7 +316,7 @@ module MakeBufferedPersistentMap include MakePersistentMap(S)(K)(C) - let read c = fold c Map.empty (fun k v m -> Lwt.return (Map.add k v m)) + let read c = fold c Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m)) let write c m = clear c >>= fun c -> @@ -399,10 +398,7 @@ module MakeImperativeProxy { rdata: rdata ; state: [ `Inited of Scheduler.data | `Initing of Scheduler.data Lwt.t ] ; wakener: Store.value Lwt.u } - type store = Store.t type state = Scheduler.state - type key = Store.key - type value = Store.value type t = { tbl : data Table.t ; @@ -594,7 +590,7 @@ module MakeHashResolver | [d] -> Store.list t [prefix] >>= fun prefixes -> Lwt_list.filter_map_p (fun prefix -> - match remove_prefix d (List.hd (List.rev prefix)) with + match remove_prefix ~prefix:d (List.hd (List.rev prefix)) with | None -> Lwt.return_none | Some _ -> Lwt.return (Some (build prefix)) ) prefixes diff --git a/src/node/db/persist.mli b/src/node/db/persist.mli index 783ceb91e..67b54e107 100644 --- a/src/node/db/persist.mli +++ b/src/node/db/persist.mli @@ -9,9 +9,6 @@ (** Tezos - Persistent structures on top of {!Context} *) -open Lwt - - (** Keys in (kex x value) database implementations *) type key = string list diff --git a/src/node/db/raw_store.ml b/src/node/db/raw_store.ml index 1862277dc..95a201baa 100644 --- a/src/node/db/raw_store.ml +++ b/src/node/db/raw_store.ml @@ -8,7 +8,6 @@ (**************************************************************************) module List = ListLabels -open Logging.Db type t = LevelDB.db type key = string list diff --git a/src/node/db/store.ml b/src/node/db/store.ml index acee8ef5a..2c0a2766b 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Store_sigs - type t = Raw_store.t type global_store = t diff --git a/src/node/db/store_helpers.ml b/src/node/db/store_helpers.ml index ad429296b..978044abe 100644 --- a/src/node/db/store_helpers.ml +++ b/src/node/db/store_helpers.ml @@ -140,7 +140,7 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct list t prefix >>= fun prefixes -> Lwt_list.map_p (function | `Key prefix | `Dir prefix -> - match Utils.remove_prefix d (List.hd (List.rev prefix)) with + match Utils.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with | None -> Lwt.return_nil | Some _ -> loop (i+1) prefix []) prefixes diff --git a/src/node/main/jbuild b/src/node/main/jbuild index b2a9cf9f6..ba54b73c9 100644 --- a/src/node/main/jbuild +++ b/src/node/main/jbuild @@ -2,8 +2,10 @@ (library ((name node_main_lib) + (public_name tezos.node.main) (libraries (utils minutils cmdliner node_net node_shell)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/node/main/node_config_file.ml b/src/node/main/node_config_file.ml index 4115ee1d6..6f702c0c4 100644 --- a/src/node/main/node_config_file.ml +++ b/src/node/main/node_config_file.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open P2p_types - let (//) = Filename.concat let home = @@ -318,7 +316,7 @@ let update Utils.first_some peer_table_size cfg.net.limits.max_known_peer_ids ; binary_chunks_size = - Utils.map_option (fun x -> x lsl 10) binary_chunks_size ; + Utils.map_option ~f:(fun x -> x lsl 10) binary_chunks_size ; } in let net : net = { expected_pow = diff --git a/src/node/main/node_config_file.mli b/src/node/main/node_config_file.mli index e84b78f0e..c1466a02d 100644 --- a/src/node/main/node_config_file.mli +++ b/src/node/main/node_config_file.mli @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open P2p_types - type t = { data_dir : string ; net : net ; diff --git a/src/node/main/node_run_command.ml b/src/node/main/node_run_command.ml index b62df094a..6a3a40ec1 100644 --- a/src/node/main/node_run_command.ml +++ b/src/node/main/node_run_command.ml @@ -47,7 +47,6 @@ let protocol_dir data_dir = data_dir // "protocol" let lock_file data_dir = data_dir // "lock" let init_logger ?verbosity (log_config : Node_config_file.log) = - let open Logging in begin match verbosity with | Some level -> @@ -61,7 +60,7 @@ let init_logger ?verbosity (log_config : Node_config_file.log) = match Sys.getenv "LWT_LOG" with | rules -> Some rules | exception Not_found -> log_config.rules in - Utils.iter_option Lwt_log_core.load_rules rules + Utils.iter_option ~f:Lwt_log_core.load_rules rules end ; Logging.init ~template:log_config.template log_config.output @@ -202,7 +201,7 @@ let run ?verbosity ?sandbox (config : Node_config_file.t) = lwt_log_notice "Shutting down the Tezos node..." >>= fun () -> Node.shutdown node >>= fun () -> lwt_log_notice "Shutting down the RPC server..." >>= fun () -> - Lwt_utils.may RPC_server.shutdown rpc >>= fun () -> + Lwt_utils.may ~f:RPC_server.shutdown rpc >>= fun () -> lwt_log_notice "BYE (%d)" x >>= fun () -> Logging.close () >>= fun () -> return () diff --git a/src/node/main/node_shared_arg.ml b/src/node/main/node_shared_arg.ml index 37811da82..a7e2216bf 100644 --- a/src/node/main/node_shared_arg.ml +++ b/src/node/main/node_shared_arg.ml @@ -8,7 +8,6 @@ (**************************************************************************) open Cmdliner -open P2p_types open Logging.Node.Main let (//) = Filename.concat @@ -51,7 +50,7 @@ let wrap let rpc_tls = Utils.map_option - (fun (cert, key) -> { Node_config_file.cert ; key }) + ~f:(fun (cert, key) -> { Node_config_file.cert ; key }) rpc_tls in (* when `--expected-connections` is used, diff --git a/src/node/main/node_shared_arg.mli b/src/node/main/node_shared_arg.mli index 74da92811..afa323c08 100644 --- a/src/node/main/node_shared_arg.mli +++ b/src/node/main/node_shared_arg.mli @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open P2p_types - type t = { data_dir: string option ; config_file: string ; diff --git a/src/node/net/jbuild b/src/node/net/jbuild index 3b101dc89..5e3072402 100644 --- a/src/node/net/jbuild +++ b/src/node/net/jbuild @@ -4,7 +4,8 @@ ((name node_net) (public_name tezos.node.net) (libraries (utils minutils conduit-lwt-unix cohttp cohttp-lwt-unix)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 3a93c776c..95a34bef3 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -131,9 +131,9 @@ let may_create_discovery_worker _config pool = let create_maintenance_worker limits pool disco = let bounds = bounds - limits.min_connections - limits.expected_connections - limits.max_connections + ~min:limits.min_connections + ~expected:limits.expected_connections + ~max:limits.max_connections in P2p_maintenance.run ~connection_timeout:limits.authentification_timeout @@ -214,7 +214,7 @@ module Real = struct let get_metadata { pool } conn = P2p_connection_pool.Peer_ids.get_metadata pool conn - let rec recv _net conn = + let recv _net conn = P2p_connection_pool.read conn >>=? fun msg -> lwt_debug "message read from %a" Connection_info.pp @@ -611,7 +611,6 @@ module RPC = struct (opt "last_miss" Time.encoding)) let info_of_point_info i = - let open P2p_connection_pool in let open P2p_connection_pool_types in let state = match Point_info.State.get i with | Requested _ -> Requested diff --git a/src/node/net/p2p_connection.ml b/src/node/net/p2p_connection.ml index b1ea6ab81..29115f5eb 100644 --- a/src/node/net/p2p_connection.ml +++ b/src/node/net/p2p_connection.ml @@ -238,7 +238,7 @@ module Reader = struct mutable worker: unit Lwt.t ; } - let rec read_message st init_mbytes = + let read_message st init_mbytes = let rec loop status = Lwt_unix.yield () >>= fun () -> let open Data_encoding.Binary in @@ -306,8 +306,8 @@ module Reader = struct end ; st.worker <- Lwt_utils.worker "reader" - (fun () -> worker_loop st []) - (fun () -> Canceler.cancel st.canceler) ; + ~run:(fun () -> worker_loop st []) + ~cancel:(fun () -> Canceler.cancel st.canceler) ; st let shutdown st = @@ -327,7 +327,7 @@ module Writer = struct binary_chunks_size: int ; (* in bytes *) } - let rec send_message st buf = + let send_message st buf = let rec loop = function | [] -> return () | buf :: l -> @@ -429,8 +429,8 @@ module Writer = struct end ; st.worker <- Lwt_utils.worker "writer" - (fun () -> worker_loop st) - (fun () -> Canceler.cancel st.canceler) ; + ~run:(fun () -> worker_loop st) + ~cancel:(fun () -> Canceler.cancel st.canceler) ; st let shutdown st = @@ -480,9 +480,6 @@ let accept end ; return conn -exception Not_available -exception Connection_closed - let catch_closed_pipe f = Lwt.catch f begin function | Lwt_pipe.Closed -> fail P2p_io_scheduler.Connection_closed diff --git a/src/node/net/p2p_connection_pool.ml b/src/node/net/p2p_connection_pool.ml index aa631a80e..b3fcdbb1e 100644 --- a/src/node/net/p2p_connection_pool.ml +++ b/src/node/net/p2p_connection_pool.ml @@ -140,8 +140,8 @@ module Answerer = struct } in st.worker <- Lwt_utils.worker "answerer" - (fun () -> worker_loop st) - (fun () -> Canceler.cancel canceler) ; + ~run:(fun () -> worker_loop st) + ~cancel:(fun () -> Canceler.cancel canceler) ; st let shutdown st = @@ -682,8 +682,6 @@ let pool_stat { io_sched } = (***************************************************************************) type error += Rejected of Peer_id.t -type error += Unexpected_point_state -type error += Unexpected_peer_id_state type error += Pending_connection type error += Connected type error += Connection_closed = P2p_io_scheduler.Connection_closed @@ -781,7 +779,7 @@ and authenticate pool ?point_info canceler fd point = if incoming then Point.Table.remove pool.incoming point else - iter_option Point_info.State.set_disconnected point_info ; + iter_option ~f:Point_info.State.set_disconnected point_info ; Lwt.return (Error err) end >>=? fun (info, auth_fd) -> (* Authentication correct! *) @@ -857,7 +855,7 @@ and authenticate pool ?point_info canceler fd point = Lwt.return (Error err) end >>=? fun conn -> let id_point = - match info.id_point, map_option Point_info.point point_info with + match info.id_point, map_option ~f:Point_info.point point_info with | (addr, _), Some (_, port) -> addr, Some port | id_point, None -> id_point in return diff --git a/src/node/net/p2p_connection_pool.mli b/src/node/net/p2p_connection_pool.mli index 180dcd6af..91cb30653 100644 --- a/src/node/net/p2p_connection_pool.mli +++ b/src/node/net/p2p_connection_pool.mli @@ -337,7 +337,7 @@ module Log_event : sig type t = - (** Pool-level events *) + (* Pool-level events *) | Too_few_connections | Too_many_connections @@ -347,10 +347,11 @@ module Log_event : sig | Gc_points (** Garbage collection of known point table has been triggered. *) + | Gc_peer_ids (** Garbage collection of known peer_ids table has been triggered. *) - (** Connection-level events *) + (* Connection-level events *) | Incoming_connection of Point.t (** We accept(2)-ed an incoming connection *) diff --git a/src/node/net/p2p_connection_pool_types.ml b/src/node/net/p2p_connection_pool_types.ml index 8374e3c39..48df90174 100644 --- a/src/node/net/p2p_connection_pool_types.ml +++ b/src/node/net/p2p_connection_pool_types.ml @@ -300,7 +300,6 @@ module Peer_info = struct | External_disconnection let kind_encoding = - let open Data_encoding in Data_encoding.string_enum [ "incoming_request", Accepting_request ; "rejecting_request", Rejecting_request ; diff --git a/src/node/net/p2p_discovery.ml b/src/node/net/p2p_discovery.ml index a051ffd89..aa9793a69 100644 --- a/src/node/net/p2p_discovery.ml +++ b/src/node/net/p2p_discovery.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open P2p_types include Logging.Make (struct let name = "p2p.discovery" end) type t = () diff --git a/src/node/net/p2p_io_scheduler.ml b/src/node/net/p2p_io_scheduler.ml index 94832c216..bd27d6f8e 100644 --- a/src/node/net/p2p_io_scheduler.ml +++ b/src/node/net/p2p_io_scheduler.ml @@ -171,8 +171,8 @@ module Scheduler(IO : IO) = struct } in st.worker <- Lwt_utils.worker IO.name - (fun () -> worker_loop st) - (fun () -> Canceler.cancel st.canceler) ; + ~run:(fun () -> worker_loop st) + ~cancel:(fun () -> Canceler.cancel st.canceler) ; st let create_connection st in_param out_param canceler id = @@ -418,7 +418,7 @@ let read_now conn ?pos ?len buf = | None -> try map_option - (read_from conn ?pos ?len buf) + ~f:(read_from conn ?pos ?len buf) (Lwt_pipe.pop_now conn.read_queue) with Lwt_pipe.Closed -> Some (Error [Connection_closed]) diff --git a/src/node/net/p2p_maintenance.ml b/src/node/net/p2p_maintenance.ml index aa20f9976..65d3b1665 100644 --- a/src/node/net/p2p_maintenance.ml +++ b/src/node/net/p2p_maintenance.ml @@ -185,8 +185,8 @@ let run ~connection_timeout bounds pool disco = } in st.maintain_worker <- Lwt_utils.worker "maintenance" - (fun () -> worker_loop st) - (fun () -> Canceler.cancel canceler) ; + ~run:(fun () -> worker_loop st) + ~cancel:(fun () -> Canceler.cancel canceler) ; st let maintain { just_maintained ; please_maintain } = diff --git a/src/node/net/p2p_types.ml b/src/node/net/p2p_types.ml index 6b938db4f..f58c2fb68 100644 --- a/src/node/net/p2p_types.ml +++ b/src/node/net/p2p_types.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Logging.Net - module Canceler = Lwt_utils.Canceler module Version = struct diff --git a/src/node/net/p2p_welcome.ml b/src/node/net/p2p_welcome.ml index 21e9a1075..650afb4af 100644 --- a/src/node/net/p2p_welcome.ml +++ b/src/node/net/p2p_welcome.ml @@ -62,8 +62,8 @@ let run ~backlog pool ?addr port = } in st.worker <- Lwt_utils.worker "welcome" - (fun () -> worker_loop st) - (fun () -> Canceler.cancel st.canceler) ; + ~run:(fun () -> worker_loop st) + ~cancel:(fun () -> Canceler.cancel st.canceler) ; Lwt.return st end begin fun exn -> lwt_log_error diff --git a/src/node/shell/chain.ml b/src/node/shell/chain.ml index d693efe06..75a66cdeb 100644 --- a/src/node/shell/chain.ml +++ b/src/node/shell/chain.ml @@ -54,7 +54,7 @@ let locked_set_head chain_store data block = Lwt.return hash in Chain_traversal.new_blocks - data.current_head block >>= fun (ancestor, path) -> + ~from_block:data.current_head ~to_block:block >>= fun (ancestor, path) -> let ancestor = Block.hash ancestor in pop_blocks ancestor data.current_head >>= fun () -> Lwt_list.fold_left_s push_block ancestor path >>= fun _ -> diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index 2ba817cbe..c04f95cb2 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -38,10 +38,6 @@ module Make_raw with type key := Hash.t and type value := Disk_table.value) = struct - type key = Hash.t - type value = Disk_table.value - type param = Disk_table.store - module Request = struct type param = Request_message.param request_param let active { active } = active () @@ -73,7 +69,6 @@ end module Fake_operation_storage = struct type store = State.Net.t - type key = Operation_hash.t type value = Operation.t let known _ _ = Lwt.return_false let read _ _ = Lwt.return (Error_monad.error_exn Not_found) @@ -98,7 +93,6 @@ module Raw_operation = module Block_header_storage = struct type store = State.Net.t - type key = Block_hash.t type value = Block_header.t let known = State.Block.known_valid let read net_state h = @@ -106,7 +100,7 @@ module Block_header_storage = struct return (State.Block.header b) let read_opt net_state h = State.Block.read_opt net_state h >>= fun b -> - Lwt.return (Utils.map_option State.Block.header b) + Lwt.return (Utils.map_option ~f:State.Block.header b) let read_exn net_state h = State.Block.read_exn net_state h >>= fun b -> Lwt.return (State.Block.header b) @@ -129,7 +123,6 @@ module Raw_block_header = module Operation_hashes_storage = struct type store = State.Net.t - type key = Block_hash.t * int type value = Operation_hash.t list let known net_state (h, _) = State.Block.known_valid net_state h let read net_state (h, i) = @@ -207,7 +200,6 @@ end module Operations_storage = struct type store = State.Net.t - type key = Block_hash.t * int type value = Operation.t list let known net_state (h, _) = State.Block.known_valid net_state h let read net_state (h, i) = @@ -276,7 +268,6 @@ end module Protocol_storage = struct type store = State.t - type key = Protocol_hash.t type value = Protocol.t let known = State.Protocol.known let read = State.Protocol.read @@ -351,8 +342,6 @@ let db { global_db } = global_db module P2p_reader = struct - type t = p2p_reader - let may_activate global_db state net_id f = match Net_id.Table.find state.peer_active_nets net_id with | net_db -> @@ -858,11 +847,6 @@ let watch_protocol { protocol_db } = Raw_protocol.Table.watch protocol_db.table module Raw = struct - type 'a t = - | Bootstrap - | Advertise of P2p_types.Point.t list - | Message of 'a - | Disconnect let encoding = P2p.Raw.encoding Message.cfg.encoding let supported_versions = Message.cfg.versions end @@ -902,7 +886,6 @@ module Make type t = Kind.t type key = Table.key type value = Table.value - type param = Table.param let known t k = Table.known (Kind.proj t) k type error += Missing_data = Table.Missing_data type error += Canceled = Table.Canceled diff --git a/src/node/shell/distributed_db_functors.ml b/src/node/shell/distributed_db_functors.ml index 13295103b..6a00203e0 100644 --- a/src/node/shell/distributed_db_functors.ml +++ b/src/node/shell/distributed_db_functors.ml @@ -323,7 +323,6 @@ end = struct include Logging.Make(struct let name = "node.distributed_db.scheduler." ^ Hash.name end) type key = Hash.t - type param = Request.param type t = { param: Request.param ; diff --git a/src/node/shell/jbuild b/src/node/shell/jbuild index 4adc3b71b..6e5bdc320 100644 --- a/src/node/shell/jbuild +++ b/src/node/shell/jbuild @@ -4,7 +4,8 @@ ((name node_shell) (public_name tezos.node.shell) (libraries (utils minutils node_net node_db node_updater ezjsonm ocplib-json-typed.bson)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index fefe7558d..8d53855be 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -619,7 +619,7 @@ module RPC = struct let block_stream, stopper = Validator.new_head_watcher node.mainnet_validator in let first_run = ref true in - let rec next () = + let next () = if !first_run then begin first_run := false ; Chain.head node.mainnet_net >>= fun head -> diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index bfd6146f4..b6cdc1bea 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -40,8 +40,6 @@ let list_pendings ~from_block ~to_block old_mempool = (** Worker *) -exception Invalid_operation of Operation_hash.t - open Prevalidation type t = { @@ -73,7 +71,7 @@ let create net_db = Chain.head net_state >>= fun head -> let timestamp = ref (Time.now ()) in - (start_prevalidation head !timestamp () >|= ref) >>= fun validation_state -> + (start_prevalidation ~predecessor:head ~timestamp:!timestamp () >|= ref) >>= fun validation_state -> let pending = Operation_hash.Table.create 53 in let head = ref head in let operations = ref empty_result in @@ -92,7 +90,7 @@ let create net_db = Lwt.return_unit in let reset_validation_state head timestamp = - start_prevalidation head timestamp () >>= fun state -> + start_prevalidation ~predecessor:head ~timestamp () >>= fun state -> validation_state := state; Lwt.return_unit in diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 4273be039..075333037 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -365,9 +365,6 @@ let apply_block net_state db module Context_db = struct - type key = Block_hash.t - type value = State.Block.t - type data = { validator: net_validator ; state: [ `Inited of Block_header.t tzresult @@ -608,7 +605,7 @@ module Context_db = struct end -let rec create_validator ?parent worker ?max_child_ttl state db net = +let create_validator ?parent worker ?max_child_ttl state db net = let net_id = State.Net.id net in let net_db = Distributed_db.activate db net in @@ -776,8 +773,6 @@ let rec create_validator ?parent worker ?max_child_ttl state db net = Lwt.return v -type error += Unknown_network of Net_id.t - let create state db = let validators : net_validator Lwt.t Net_id.Table.t = diff --git a/src/node/updater/jbuild b/src/node/updater/jbuild index 2b43c7c27..c2992089f 100644 --- a/src/node/updater/jbuild +++ b/src/node/updater/jbuild @@ -4,7 +4,8 @@ ((name node_updater) (public_name tezos.node.updater) (libraries (utils minutils micheline tezos_protocol_compiler node_db dynlink)) - (flags (:standard -w +27-30-40@8 + (flags (:standard -w -9+27-30-32-40@8 + -safe-string -open Error_monad -open Hash -open Utils diff --git a/src/proto/alpha/jbuild b/src/proto/alpha/jbuild index 7280c038b..5098a9c19 100644 --- a/src/proto/alpha/jbuild +++ b/src/proto/alpha/jbuild @@ -27,7 +27,7 @@ let () = (library ((name tezos_protocol_environment_alpha) (public_name tezos.protocol_environment.alpha) - (library_flags (:standard -linkall)) + (library_flags (:standard -linkall -w -9 -safe-string)) (libraries (node_updater)) (modules (Environment)))) @@ -36,8 +36,8 @@ let () = (public_name tezos.embedded_raw_protocol.alpha) (libraries (tezos_protocol_environment_alpha)) (library_flags (:standard -linkall)) - (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-40..42-44-45-48 + (flags (:standard -nopervasives -nostdlib -safe-string + -w +a-4-6-7-9-29-32-40..42-44-45-48 -warn-error -a+8 -open Tezos_protocol_environment_alpha__Environment -open Error_monad @@ -48,7 +48,7 @@ let () = (library ((name tezos_embedded_protocol_alpha) (public_name tezos.embedded_protocol.alpha) - (library_flags (:standard -linkall)) + (library_flags (:standard -linkall -w -9-32 -safe-string)) (libraries (tezos_embedded_raw_protocol_alpha node_shell)) (modules (Registerer)))) diff --git a/src/proto/demo/jbuild b/src/proto/demo/jbuild index 15c1b4c72..b888f9d1f 100644 --- a/src/proto/demo/jbuild +++ b/src/proto/demo/jbuild @@ -32,8 +32,8 @@ ((name tezos_embedded_raw_protocol_demo) (libraries (tezos_protocol_environment_demo)) (library_flags (:standard -linkall)) - (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-40..42-44-45-48 + (flags (:standard -nopervasives -nostdlib -safe-string + -w +a-4-6-7-9-29-32-40..42-44-45-48 -warn-error -a+8 -open Tezos_protocol_environment_demo__Environment -open Error_monad @@ -43,7 +43,7 @@ (library ((name tezos_embedded_protocol_demo) - (library_flags (:standard -linkall)) + (library_flags (:standard -linkall -w -9-32 -safe-string)) (libraries (tezos_embedded_raw_protocol_demo node_shell)) (modules (Registerer)))) diff --git a/src/proto/genesis/jbuild b/src/proto/genesis/jbuild index 9c1380627..be28681e5 100644 --- a/src/proto/genesis/jbuild +++ b/src/proto/genesis/jbuild @@ -25,15 +25,17 @@ (library ((name tezos_protocol_environment_genesis) + (public_name tezos.protocol_environment.genesis) (libraries (node_updater)) (modules (Environment)))) (library ((name tezos_embedded_raw_protocol_genesis) + (public_name tezos.embedded_raw_protocol.genesis) (libraries (tezos_protocol_environment_genesis)) (library_flags (:standard -linkall)) - (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-40..42-44-45-48 + (flags (:standard -nopervasives -nostdlib -safe-string + -w +a-4-6-7-9-29-32-40..42-44-45-48 -warn-error -a+8 -open Tezos_protocol_environment_genesis__Environment -open Error_monad @@ -43,7 +45,8 @@ (library ((name tezos_embedded_protocol_genesis) - (library_flags (:standard -linkall)) + (public_name tezos.embedded_protocol.genesis) + (library_flags (:standard -linkall -w -9-32 -safe-string)) (libraries (tezos_embedded_raw_protocol_genesis node_shell)) (modules (Registerer)))) diff --git a/src/utils/base58.ml b/src/utils/base58.ml index 1bf43f6a1..6a954127b 100644 --- a/src/utils/base58.ml +++ b/src/utils/base58.ml @@ -168,8 +168,8 @@ module MakeEncodings(E: sig let check_ambiguous_prefix prefix encodings = List.iter (fun (Encoding { encoded_prefix = s }) -> - if remove_prefix s prefix <> None || - remove_prefix prefix s <> None then + if remove_prefix ~prefix:s prefix <> None || + remove_prefix ~prefix s <> None then Format.ksprintf invalid_arg "Base58.register_encoding: duplicate prefix: %S, %S." s prefix) encodings diff --git a/src/utils/cli_entries.ml b/src/utils/cli_entries.ml index faac777c4..2c58278d4 100644 --- a/src/utils/cli_entries.ml +++ b/src/utils/cli_entries.ml @@ -287,14 +287,14 @@ let command ?group ~desc options params handler = (* Param combinators *) let string ~name ~desc next = - param name desc { converter=(fun _ s -> return s) ; autocomplete=None } next + param ~name ~desc { converter=(fun _ s -> return s) ; autocomplete=None } next (* Help commands *) let help_group = { name = "man" ; title = "Access the documentation" } -let rec string_contains ~needle ~haystack = +let string_contains ~needle ~haystack = try Some (Str.search_forward (Str.regexp_string needle) haystack 0) with Not_found -> @@ -539,7 +539,7 @@ let has_args : type a ctx. (a, ctx) args -> bool = function | NoArgs -> false | AddArg (_,_) -> true -let rec print_options_brief (type ctx) = +let print_options_brief (type ctx) = let help_option : type a. Format.formatter -> (a, ctx) arg -> unit = fun ppf -> function @@ -631,7 +631,7 @@ let contains_params_args : in help params let print_command : - type a ctx ret. ?prefix: string -> ?highlights:string list -> Format.formatter -> (ctx, ret) command -> unit + type ctx ret. ?prefix: string -> ?highlights:string list -> Format.formatter -> (ctx, ret) command -> unit = fun ?(prefix = "") ?(highlights=[]) ppf (Command { params ; desc ; options=Argument { spec } }) -> if contains_params_args params spec then @@ -686,7 +686,6 @@ let command_args_help ppf command = command let usage - (type ctx) (type ret) ppf ?global_options ~details @@ -727,7 +726,7 @@ let usage Format.fprintf ppf "@]" let command_usage - (type ctx) (type ret) ppf commands = + ppf commands = let exe = Filename.basename Sys.executable_name in let prefix = exe ^ " [global options] " in Format.fprintf ppf diff --git a/src/utils/cli_entries.mli b/src/utils/cli_entries.mli index 96d54c3ad..09ef7c321 100644 --- a/src/utils/cli_entries.mli +++ b/src/utils/cli_entries.mli @@ -21,6 +21,7 @@ val parameter : ?autocomplete:('ctx -> string list tzresult Lwt.t) -> (** {2 Flags and Options } *) (** {3 Options and Switches } *) + (** Type for option or switch *) type ('a, 'ctx) arg @@ -37,6 +38,7 @@ val default_arg : doc:string -> parameter:string -> default:string -> ('p, 'ctx) parameter -> ('p, 'ctx) arg + (** Create a boolean switch. The value will be set to [true] if the switch is provided and [false] if it is not. *) val switch : doc:string -> parameter:string -> @@ -144,6 +146,7 @@ val prefix: string -> ('a, 'ctx, 'ret) params -> ('a, 'ctx, 'ret) params + (** Multiple words given in sequence for a command line *) val prefixes: string list -> @@ -154,6 +157,7 @@ val prefixes: val fixed: string list -> ('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params + (** End the description of the command line *) val stop: ('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params diff --git a/src/utils/crypto_box.ml b/src/utils/crypto_box.ml index 91a0fe8bf..623ce9831 100644 --- a/src/utils/crypto_box.ml +++ b/src/utils/crypto_box.ml @@ -7,8 +7,6 @@ (* *) (**************************************************************************) -open Utils - (** Tezos - X25519/XSalsa20-Poly1305 cryptography *) type secret_key = Sodium.Box.secret_key @@ -16,7 +14,6 @@ type public_key = Sodium.Box.public_key type channel_key = Sodium.Box.channel_key type nonce = Sodium.Box.nonce type target = Z.t -exception TargetNot256Bit module Public_key_hash = Hash.Make_Blake2B (Base58) (struct let name = "Crypto_box.Public_key_hash" diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 15494a984..21976961e 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -40,8 +40,6 @@ module Make() = struct pp: Format.formatter -> 'err -> unit ; } -> error_kind - type registred_errors = error_kind list - let error_kinds : error_kind list ref = ref [] @@ -281,7 +279,7 @@ module Make() = struct filter_map_s f t >>=? fun rt -> return (rh :: rt) - let rec filter_map_p f l = + let filter_map_p f l = match l with | [] -> return [] | h :: t -> diff --git a/src/utils/hash.ml b/src/utils/hash.ml index 008ae57a3..3a0833171 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -7,14 +7,11 @@ (* *) (**************************************************************************) -open Error_monad - let (//) = Filename.concat let (>>=) = Lwt.bind let (>|=) = Lwt.(>|=) open Error_monad -open Utils let () = let expected_primitive = "blake2b" @@ -549,7 +546,6 @@ module Generic_hash = module Net_id = struct type t = string - type net_id = t let name = "Net_id" let title = "Network identifier" diff --git a/src/utils/jbuild b/src/utils/jbuild index eaa202d38..b317dad7a 100644 --- a/src/utils/jbuild +++ b/src/utils/jbuild @@ -18,7 +18,7 @@ ;; Internal minutils )) - (flags (:standard -w +27-30-40@8)) + (flags (:standard -w -9+27-30-32-40@8 -safe-string)) (wrapped false))) diff --git a/src/utils/lwt_dropbox.ml b/src/utils/lwt_dropbox.ml index 2528ec756..0df4c351d 100644 --- a/src/utils/lwt_dropbox.ml +++ b/src/utils/lwt_dropbox.ml @@ -30,7 +30,7 @@ let notify_put dropbox = dropbox.put_waiter <- None ; Lwt.wakeup_later w () -let rec put dropbox elt = +let put dropbox elt = if dropbox.closed then raise Closed else begin diff --git a/src/utils/lwt_pipe.ml b/src/utils/lwt_pipe.ml index 670b0bad3..a3fb8a401 100644 --- a/src/utils/lwt_pipe.ml +++ b/src/utils/lwt_pipe.ml @@ -91,9 +91,9 @@ let rec push ({ closed ; queue ; current_size ; wait_pop q >>= fun () -> push q elt -let rec push_now ({ closed ; queue ; compute_size ; - current_size ; max_size - } as q) elt = +let push_now ({ closed ; queue ; compute_size ; + current_size ; max_size + } as q) elt = if closed then raise Closed ; let elt_size = compute_size elt in (current_size + elt_size < max_size || Queue.is_empty queue) diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 891b2d75d..7e58f2a82 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -358,7 +358,7 @@ let stable_sort cmp l = let sort = stable_sort -let rec read_bytes ?(pos = 0) ?len fd buf = +let read_bytes ?(pos = 0) ?len fd buf = let len = match len with None -> Bytes.length buf - pos | Some l -> l in let rec inner pos len = if len = 0 then diff --git a/src/utils/time.ml b/src/utils/time.ml index c4ea6f4dc..b6cf3d32a 100644 --- a/src/utils/time.ml +++ b/src/utils/time.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) -open Error_monad open CalendarLib module T = struct diff --git a/test/lib/jbuild b/test/lib/jbuild index edc86d136..74be2f013 100644 --- a/test/lib/jbuild +++ b/test/lib/jbuild @@ -3,4 +3,5 @@ (library ((name test_lib) (libraries (kaputt utils minutils)) - (wrapped false))) + (wrapped false) + (flags (:standard -w -9-32 -safe-string)))) diff --git a/test/lib/node_helpers.ml b/test/lib/node_helpers.ml index 308d98903..082954c7f 100644 --- a/test/lib/node_helpers.ml +++ b/test/lib/node_helpers.ml @@ -38,7 +38,7 @@ let fork_node ?(timeout = 4) ?(port = 18732) ?sandbox () = let null_fd = Unix.(openfile "/dev/null" [O_RDONLY] 0o644) in let exe = let (//) = Filename.concat in - Filename.(Sys.getcwd () // ".." // "src" // "node_main.exe") in + Sys.getcwd () // ".." // "src" // "node_main.exe" in let pid = Unix.create_process exe [| "tezos-node" ; diff --git a/test/p2p/jbuild b/test/p2p/jbuild index 661fff598..bac16d954 100644 --- a/test/p2p/jbuild +++ b/test/p2p/jbuild @@ -5,7 +5,9 @@ test_p2p_connection_pool test_p2p_io_scheduler)) (libraries (minutils utils test_lib node_net)) - (flags (:standard -linkall + (flags (:standard -w -9-32 + -linkall + -safe-string -open Error_monad -open Hash -open Utils diff --git a/test/p2p/test_p2p_connection.ml b/test/p2p/test_p2p_connection.ml index 55267bebc..a54e948fd 100644 --- a/test/p2p/test_p2p_connection.ml +++ b/test/p2p/test_p2p_connection.ml @@ -370,7 +370,6 @@ let spec = Arg.[ ] let main () = - let open Utils in let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in let usage_msg = "Usage: %s.\nArguments are:" in Arg.parse spec anon_fun usage_msg ; diff --git a/test/proto_alpha/jbuild b/test/proto_alpha/jbuild index 161b7a9fe..c9f42d9f3 100644 --- a/test/proto_alpha/jbuild +++ b/test/proto_alpha/jbuild @@ -10,7 +10,8 @@ client_lib client_embedded_genesis client_embedded_alpha)) - (flags (:standard -open Error_monad + (flags (:standard -w -9-32 -safe-string + -open Error_monad -open Hash -open Tezos_data -open Tezos_protocol_environment_alpha diff --git a/test/proto_alpha/proto_alpha_helpers.mli b/test/proto_alpha/proto_alpha_helpers.mli index 9ad56ab22..52b4c6452 100644 --- a/test/proto_alpha/proto_alpha_helpers.mli +++ b/test/proto_alpha/proto_alpha_helpers.mli @@ -171,6 +171,7 @@ module Assert : sig val unknown_contract : msg:string -> 'a tzresult -> unit (** [unknown_contract ~msg result] raises if result is not a [Storage_error]. *) + val non_existing_contract : msg:string -> 'a tzresult -> unit val balance_too_low : msg:string -> 'a tzresult -> unit val non_spendable : msg:string -> 'a tzresult -> unit diff --git a/test/shell/jbuild b/test/shell/jbuild index ef7579dc4..ab06ca296 100644 --- a/test/shell/jbuild +++ b/test/shell/jbuild @@ -11,7 +11,9 @@ tezos_embedded_protocol_demo tezos_embedded_protocol_alpha tezos_embedded_protocol_genesis)) - (flags (:standard -open Error_monad + (flags (:standard -w -9-32 + -safe-string + -open Error_monad -open Hash -open Utils -open Tezos_data)))) diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index bd8f1ae36..a69558f0d 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -93,7 +93,7 @@ type t = { let wrap_context_init f base_dir = let root = base_dir // "context" in - Context.init root >>= fun idx -> + Context.init ~root ?patch_context:None >>= fun idx -> Context.commit_genesis idx ~net_id ~time:genesis.time diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index 6e6821417..ac3fb2596 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -217,7 +217,6 @@ let test_hashset (type t) (Make_substore(Store)(struct let name = ["test_set"] end)) (Block_hash) (BlockSet) in - let open BlockSet in let bhset : BlockSet.t = BlockSet.add bh2 (BlockSet.add bh1 BlockSet.empty) in StoreSet.store_all s bhset >>= fun () -> StoreSet.read_all s >>= fun bhset' -> @@ -227,8 +226,8 @@ let test_hashset (type t) StoreSet.store_all s bhset2 >>= fun () -> StoreSet.read_all s >>= fun bhset2' -> Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2' ; - StoreSet.fold s BlockSet.empty - (fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' -> + StoreSet.fold s ~init:BlockSet.empty + ~f:(fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' -> Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2'' ; Store.store s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> StoreSet.remove_all s >>= fun () -> diff --git a/test/utils/jbuild b/test/utils/jbuild index 952c319a0..0f6e9b09a 100644 --- a/test/utils/jbuild +++ b/test/utils/jbuild @@ -7,7 +7,9 @@ test_stream_data_encoding test_utils)) (libraries (minutils utils test_lib)) - (flags (:standard -open Error_monad + (flags (:standard -w -9-32 + -safe-string + -open Error_monad -open Hash -open Utils -open Tezos_data)))) diff --git a/test/utils/test_data_encoding.ml b/test/utils/test_data_encoding.ml index 98ace12be..34ec2d873 100644 --- a/test/utils/test_data_encoding.ml +++ b/test/utils/test_data_encoding.ml @@ -1,5 +1,4 @@ open Data_encoding -open Hash open Error_monad let (>>=) = Lwt.bind diff --git a/test/utils/test_merkle.ml b/test/utils/test_merkle.ml index a30a1685c..15154495f 100644 --- a/test/utils/test_merkle.ml +++ b/test/utils/test_merkle.ml @@ -8,7 +8,6 @@ (**************************************************************************) open Error_monad -open Hash let rec (--) i j = if j < i then [] diff --git a/test/utils/test_stream_data_encoding.ml b/test/utils/test_stream_data_encoding.ml index 746c00160..c5e50259e 100644 --- a/test/utils/test_stream_data_encoding.ml +++ b/test/utils/test_stream_data_encoding.ml @@ -1,5 +1,4 @@ open Data_encoding -open Hash open Error_monad let (>>=) = Lwt.bind @@ -22,7 +21,7 @@ let rec fold_left_pending f accu l = | a::l -> fold_left_pending f (f accu a l) l let test_read_simple_bin_ko_invalid_data - ?msg ?(not_equal=Assert.not_equal) encoding value = + ?(not_equal=Assert.not_equal) encoding value = let len_data = MBytes.length (Binary.to_bytes encoding value) in if classify encoding != `Variable && len_data > 0 then for sz = 1 to len_data do @@ -64,14 +63,14 @@ let test_read_simple_bin_ko_invalid_data let unexpected loc = loc ^ ": This case should not happen" -let test_read_simple_bin_ko_await ?msg encoding value = +let test_read_simple_bin_ko_await encoding value = let len_data = MBytes.length (Binary.to_bytes encoding value) in if classify encoding != `Variable && len_data > 0 then for sz = 1 to len_data do let l = Binary.to_bytes_list sz encoding value in match List.rev l with | [] -> Assert.fail_msg "%s" (unexpected __LOC__) - | e::r -> + | _ :: r -> let l = List.rev r in (* last mbyte removed !! *) ignore( fold_left_pending @@ -96,7 +95,7 @@ let test_read_simple_bin_ko_await ?msg encoding value = | Binary.Error -> if not (classify encoding == `Variable) then Assert.fail_msg "%s" (unexpected __LOC__) - | Binary.Success result -> + | Binary.Success _ -> Assert.fail_msg "%s" (unexpected __LOC__) end; _done @@ -139,7 +138,7 @@ let test_read_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value = done let test_check_simple_bin_ko_invalid_data - ?msg ?(not_equal=Assert.not_equal) encoding value = + encoding value = let len_data = MBytes.length (Binary.to_bytes encoding value) in if classify encoding != `Variable && len_data > 0 then for sz = 1 to len_data do @@ -168,7 +167,7 @@ let test_check_simple_bin_ko_invalid_data match status with | Binary.Await _ -> () | Binary.Error -> () - | Binary.Success {res; remaining} -> + | Binary.Success { remaining } -> Assert.equal ~msg:__LOC__ remaining []; (* res is unit for check *) end; @@ -177,14 +176,14 @@ let test_check_simple_bin_ko_invalid_data ) done -let test_check_simple_bin_ko_await ?msg encoding value = +let test_check_simple_bin_ko_await encoding value = let len_data = MBytes.length (Binary.to_bytes encoding value) in if classify encoding != `Variable && len_data > 0 then for sz = 1 to len_data do let l = Binary.to_bytes_list sz encoding value in match List.rev l with | [] -> Assert.fail_msg "%s" (unexpected __LOC__) - | e::r -> + | _ :: r -> let l = List.rev r in (* last mbyte removed !! *) ignore( fold_left_pending @@ -209,7 +208,7 @@ let test_check_simple_bin_ko_await ?msg encoding value = | Binary.Error -> if not (classify encoding == `Variable) then Assert.fail_msg "%s" (unexpected __LOC__) - | Binary.Success result -> + | Binary.Success _ -> Assert.fail_msg "%s" (unexpected __LOC__) end; _done @@ -217,7 +216,7 @@ let test_check_simple_bin_ko_await ?msg encoding value = ) done -let test_check_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value = +let test_check_simple_bin_ok encoding value = let len_data = max 1 (MBytes.length (Binary.to_bytes encoding value)) in for sz = 1 to len_data do ignore( @@ -238,7 +237,7 @@ let test_check_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value = )status _todo in match status with - | Binary.Success {res; remaining} -> + | Binary.Success { remaining } -> Assert.equal ~msg:__LOC__ remaining []; (* res is unit for check *) | Binary.Await _ -> Assert.fail_msg "%s" (unexpected __LOC__) @@ -254,15 +253,14 @@ let test_check_simple_bin_ok ?msg ?(equal=Assert.equal) encoding value = let test_simple ~msg ?(equal=Assert.equal) ?(not_equal=Assert.not_equal) enc value = - test_check_simple_bin_ok ~msg:(msg ^ ": binary-ok") ~equal enc value; - test_check_simple_bin_ko_await ~msg:(msg ^ ": binary-ko_await") enc value; - test_check_simple_bin_ko_invalid_data - ~msg:(msg ^ ": binary-invalid_data") ~not_equal enc value; + test_check_simple_bin_ok enc value; + test_check_simple_bin_ko_await enc value; + test_check_simple_bin_ko_invalid_data enc value; test_read_simple_bin_ok ~msg:(msg ^ ": binary-ok") ~equal enc value; - test_read_simple_bin_ko_await ~msg:(msg ^ ": binary-ko_await") enc value; + test_read_simple_bin_ko_await enc value; test_read_simple_bin_ko_invalid_data - ~msg:(msg ^ ": binary-invalid_data") ~not_equal enc value + ~not_equal enc value diff --git a/test/utils/test_utils.ml b/test/utils/test_utils.ml index 58897a70e..e66d4fa51 100644 --- a/test/utils/test_utils.ml +++ b/test/utils/test_utils.ml @@ -8,7 +8,6 @@ (**************************************************************************) open Error_monad -open Hash let rec (--) i j = if j < i then []