diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8930fa9b0..0eb2c3159 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -72,6 +72,11 @@ build: dependencies: - build +test:ocp-indent: + <<: *test_definition + script: + - jbuilder build @runtest_indent + test:utils: <<: *test_definition script: diff --git a/jbuild b/jbuild index 5e0ae1705..a30ff1f86 100644 --- a/jbuild +++ b/jbuild @@ -1 +1,63 @@ (jbuild_version 1) + +(alias + ((name runtest_indent) + (deps ( ;; Hack... list all directories + (glob_files scripts/*.ml) + (glob_files scripts/*.mli) + (glob_files src/*.ml) + (glob_files src/*.mli) + (glob_files src/attacker/*.ml) + (glob_files src/attacker/*.mli) + (glob_files src/client/*.ml) + (glob_files src/client/*.mli) + (glob_files src/client/embedded/alpha/*.ml) + (glob_files src/client/embedded/alpha/*.mli) + (glob_files src/client/embedded/demo/*.ml) + (glob_files src/client/embedded/demo/*.mli) + (glob_files src/client/embedded/genesis/*.ml) + (glob_files src/client/embedded/genesis/*.mli) + (glob_files src/compiler/*.ml) + (glob_files src/compiler/*.mli) + (glob_files src/environment/sigs_packer/*.ml) + (glob_files src/environment/sigs_packer/*.mli) + (glob_files src/environment/v1/*.ml) + (glob_files src/environment/v1/*.mli) + (glob_files src/micheline/*.ml) + (glob_files src/micheline/*.mli) + (glob_files src/minutils/*.ml) + (glob_files src/minutils/*.mli) + (glob_files src/node/db/*.ml) + (glob_files src/node/db/*.mli) + (glob_files src/node/main/*.ml) + (glob_files src/node/main/*.mli) + (glob_files src/node/net/*.ml) + (glob_files src/node/net/*.mli) + (glob_files src/node/shell/*.ml) + (glob_files src/node/shell/*.mli) + (glob_files src/node/updater/*.ml) + (glob_files src/node/updater/*.mli) + (glob_files src/proto/alpha/*.ml) + (glob_files src/proto/alpha/*.mli) + (glob_files src/proto/demo/*.ml) + (glob_files src/proto/demo/*.mli) + (glob_files src/proto/genesis/*.ml) + (glob_files src/proto/genesis/*.mli) + (glob_files src/utils/*.ml) + (glob_files src/utils/*.mli) + (glob_files test/lib/*.ml) + (glob_files test/lib/*.mli) + (glob_files test/p2p/*.ml) + (glob_files test/p2p/*.mli) + (glob_files test/proto_alpha/*.ml) + (glob_files test/proto_alpha/*.mli) + (glob_files test/shell/*.ml) + (glob_files test/shell/*.mli) + (glob_files test/utils/*.ml) + (glob_files test/utils/*.mli) + )) + (action (run bash ${path:scripts/test-ocp-indent.sh})))) + +(alias + ((name runtest) + (deps ((alias runtest_indent))))) diff --git a/scripts/test-ocp-indent.sh b/scripts/test-ocp-indent.sh new file mode 100755 index 000000000..6d3574660 --- /dev/null +++ b/scripts/test-ocp-indent.sh @@ -0,0 +1,22 @@ +#!/bin/sh + +tmp_dir="$(mktemp -d -t tezos_build.XXXXXXXXXX)" +failed=no + +for f in ` find \( -name _build -or \ + -name .git -or \ + -wholename ./src/environment/v1.ml -or \ + -name registerer.ml \) -prune -or \ + \( -name \*.ml -or -name \*.mli \) -print`; do + ff=$(basename $f) + ocp-indent $f > $tmp_dir/$ff + diff -u --color $f $tmp_dir/$ff + if [ $? -ne 0 ]; then + failed=yes + fi + rm -f $tmp_dir/$ff $tmp_dir/$ff.diff +done + +if [ $failed = "yes" ]; then + exit 2 +fi diff --git a/src/attacker/attacker_minimal.ml b/src/attacker/attacker_minimal.ml index 233889101..434529e27 100644 --- a/src/attacker/attacker_minimal.ml +++ b/src/attacker/attacker_minimal.ml @@ -34,10 +34,10 @@ let block_forged ?prev ops = Proto.Fitness_repr.int64_to_bytes x ] in let pred = match prev with None -> genesis_block_hashed | Some x -> x in let block ops = Store.Block_header.{ net_id = network ; - predecessor = pred ; - timestamp = Time.now () ; - fitness = from_int64 1L; - operations = ops } in + predecessor = pred ; + timestamp = Time.now () ; + fitness = from_int64 1L; + operations = ops } in let open Proto in let generate_proof_of_work_nonce () = Sodium.Random.Bigbytes.generate @@ -70,12 +70,12 @@ let tx_forged ?dest amount fee = parameters = None ; destination = default_contract trgt.public_key_hash ; } in let op = Sourced_operations - ( Manager_operations - { source = default_contract src.public_key_hash ; - public_key = Some src.public_key ; - fee = of_cents_exn fee ; - counter = 1l ; - operations = [tx] ; }) in + ( Manager_operations + { source = default_contract src.public_key_hash ; + public_key = Some src.public_key ; + fee = of_cents_exn fee ; + counter = 1l ; + operations = [tx] ; }) in forge { net_id = network } op (* forge a list of proposals, california eat your heart out *) @@ -98,7 +98,7 @@ let ballot_forged period prop vote = period = period ; proposal = prop ; ballot = vote - } in + } in let op = Sourced_operations (Delegate_operations { source = src.public_key ; operations = [ballot] }) in diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 62548d8f7..6cd8fd2cc 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -233,13 +233,13 @@ module Alias = functor (Entity : Entity) -> struct iter_s (fun (n, _v) -> if n = s then - Entity.to_source cctxt _v >>=? fun value -> - failwith - "@[The %s alias %s already exists.@,\ - The current value is %s.@,\ - Use -force true to update@]" - Entity.name n - value + Entity.to_source cctxt _v >>=? fun value -> + failwith + "@[The %s alias %s already exists.@,\ + The current value is %s.@,\ + Use -force true to update@]" + Entity.name n + value else return ()) list @@ -289,9 +289,9 @@ module Alias = functor (Entity : Entity) -> struct end)) next - let name cctxt d = - rev_find cctxt d >>=? function - | None -> Entity.to_source cctxt d - | Some name -> return name + let name cctxt d = + rev_find cctxt d >>=? function + | None -> Entity.to_source cctxt d + | Some name -> return name end diff --git a/src/client/client_config.ml b/src/client/client_config.ml index 4c92ad34d..edb32696e 100644 --- a/src/client/client_config.ml +++ b/src/client/client_config.ml @@ -162,9 +162,9 @@ let port_arg = ~default:(string_of_int Cfg_file.default.node_port) (parameter (fun _ x -> try - return (int_of_string x) - with Failure _ -> - fail (Invalid_port_arg x))) + return (int_of_string x) + with Failure _ -> + fail (Invalid_port_arg x))) let tls_switch = switch ~parameter:"-tls" diff --git a/src/client/client_helpers.ml b/src/client/client_helpers.ml index c233a1168..8fcd44332 100644 --- a/src/client/client_helpers.ml +++ b/src/client/client_helpers.ml @@ -53,5 +53,5 @@ let commands () = Cli_entries.[ ) stream >>= fun () -> cctxt.answer "Bootstrapped." >>= fun () -> return () -) + ) ] diff --git a/src/client/client_protocols.ml b/src/client/client_protocols.ml index 406e97ec8..6c5222152 100644 --- a/src/client/client_protocols.ml +++ b/src/client/client_protocols.ml @@ -45,7 +45,7 @@ let commands () = | Ok hash -> cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () -> return () - + | Error err -> cctxt.error "Error while injecting protocol from %s: %a" dirname Error_monad.pp_print_error err >>= fun () -> @@ -66,8 +66,8 @@ let commands () = Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () -> cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () -> return () - ) ; - (* | Error err -> *) - (* cctxt.error "Error while dumping protocol %a: %a" *) - (* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *) + ) ; + (* | Error err -> *) + (* cctxt.error "Error while dumping protocol %a: %a" *) + (* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *) ] diff --git a/src/client/client_rpcs.ml b/src/client/client_rpcs.ml index d626b5abd..16f29cab2 100644 --- a/src/client/client_rpcs.ml +++ b/src/client/client_rpcs.ml @@ -109,14 +109,14 @@ let rpc_error_encoding = (req "message" string)) (function Cannot_connect_to_RPC_server msg -> Some ((), msg) | _ -> None) (function (), msg -> Cannot_connect_to_RPC_server msg) ; - case ~tag: 2 + case ~tag: 2 (obj3 (req "rpc_error_kind" (constant "request_failed")) (req "path" (list string)) (req "http_code" (conv Cohttp.Code.code_of_status Cohttp.Code.status_of_code uint16))) (function Request_failed (path, code) -> Some ((), path, code) | _ -> None) (function (), path, code -> Request_failed (path, code)) ; - case ~tag: 3 + case ~tag: 3 (obj4 (req "rpc_error_kind" (constant "malformed_json")) (req "path" (list string)) @@ -124,7 +124,7 @@ let rpc_error_encoding = (req "text" string)) (function Malformed_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None) (function (), path, msg, json -> Malformed_json (path, json, msg)) ; - case ~tag: 4 + case ~tag: 4 (obj4 (req "rpc_error_kind" (constant "unexpected_json")) (req "path" (list string)) diff --git a/src/client/client_tags.ml b/src/client/client_tags.ml index 1073b465d..4516c8d80 100644 --- a/src/client/client_tags.ml +++ b/src/client/client_tags.ml @@ -35,30 +35,30 @@ module Tags (Entity : Entity) = struct include Client_aliases.Alias (struct - type t = Tag.t + type t = Tag.t - let encoding = Tag.encoding + let encoding = Tag.encoding - (* Split a string of tags separated by commas, and possibly spaces *) - let of_source _ tags_str = - let rec aux tags s = - try - let idx = String.index s ',' in - let tag = String.(trim (sub s 0 idx)) in - let tail = String.(sub s (idx + 1) (length s - (idx + 1))) in - aux (tag :: tags) tail - with - | Not_found -> - String.(trim s) :: tags - in - return (aux [] tags_str) + (* Split a string of tags separated by commas, and possibly spaces *) + let of_source _ tags_str = + let rec aux tags s = + try + let idx = String.index s ',' in + let tag = String.(trim (sub s 0 idx)) in + let tail = String.(sub s (idx + 1) (length s - (idx + 1))) in + aux (tag :: tags) tail + with + | Not_found -> + String.(trim s) :: tags + in + return (aux [] tags_str) - let to_source _ tags = - return (String.concat ", " tags) + let to_source _ tags = + return (String.concat ", " tags) - let name = Entity.name ^ " tag" + let name = Entity.name ^ " tag" - end) + end) let tag_param ?(name = "tag") ?(desc = "list of tags") next = let desc = diff --git a/src/client/embedded/alpha/client_baking_blocks.ml b/src/client/embedded/alpha/client_baking_blocks.ml index 403641c2b..c93fb64d9 100644 --- a/src/client/embedded/alpha/client_baking_blocks.ml +++ b/src/client/embedded/alpha/client_baking_blocks.ml @@ -45,7 +45,7 @@ let compare (bi1 : block_info) (bi2 : block_info) = match Time.compare bi1.timestamp bi2.timestamp with | 0 -> Block_hash.compare bi1.predecessor bi2.predecessor | x -> - x - end + end | x -> - x end | x -> x diff --git a/src/client/embedded/alpha/client_baking_endorsement.ml b/src/client/embedded/alpha/client_baking_endorsement.ml index 5d829e3de..38aefca05 100644 --- a/src/client/embedded/alpha/client_baking_endorsement.ml +++ b/src/client/embedded/alpha/client_baking_endorsement.ml @@ -244,7 +244,7 @@ let schedule_endorsements cctxt state bis = then begin lwt_log_info "Schedule endorsement for block %a \ - \ (level %a, slot %d, time %a) (replace block %a)" + \ (level %a, slot %d, time %a) (replace block %a)" Block_hash.pp_short block.hash Raw_level.pp level slot diff --git a/src/client/embedded/alpha/client_baking_forge.ml b/src/client/embedded/alpha/client_baking_forge.ml index f2a997d72..823d020ec 100644 --- a/src/client/embedded/alpha/client_baking_forge.ml +++ b/src/client/embedded/alpha/client_baking_forge.ml @@ -92,8 +92,8 @@ let () = pp_print_error err) Data_encoding. (obj2 - (req "operation" (dynamic_size Client_node_rpcs.operation_encoding)) - (req "error" Node_rpc_services.Error.encoding)) + (req "operation" (dynamic_size Client_node_rpcs.operation_encoding)) + (req "error" Node_rpc_services.Error.encoding)) (function | Failed_to_preapply (hash, err) -> Some (hash, err) | _ -> None) @@ -147,7 +147,7 @@ let forge_block cctxt block failwith "No slot found at level %a" Raw_level.pp level end >>=? fun (priority, minimal_timestamp) -> (* lwt_log_info "Baking block at level %a prio %d" *) - (* Raw_level.pp level priority >>= fun () -> *) + (* Raw_level.pp level priority >>= fun () -> *) begin match timestamp, minimal_timestamp with | None, timestamp -> return timestamp @@ -172,9 +172,9 @@ let forge_block cctxt block lwt_log_info "Computed fitness %a" Fitness.pp shell_header.fitness >>= fun () -> if best_effort - || ( Operation_hash.Map.is_empty result.refused - && Operation_hash.Map.is_empty result.branch_refused - && Operation_hash.Map.is_empty result.branch_delayed ) then + || ( Operation_hash.Map.is_empty result.refused + && Operation_hash.Map.is_empty result.branch_refused + && Operation_hash.Map.is_empty result.branch_delayed ) then let operations = if not best_effort then operations else @@ -206,11 +206,11 @@ let forge_block cctxt block (op, Operation_hash.Map.find h result.refused)) with Not_found -> try Some (Failed_to_preapply - (op, Operation_hash.Map.find h result.branch_refused)) - with Not_found -> - try Some (Failed_to_preapply - (op, Operation_hash.Map.find h result.branch_delayed)) - with Not_found -> None) + (op, Operation_hash.Map.find h result.branch_refused)) + with Not_found -> + try Some (Failed_to_preapply + (op, Operation_hash.Map.find h result.branch_delayed)) + with Not_found -> None) operations @@ -594,9 +594,9 @@ let create (fun ppf bi -> Block_hash.pp_short ppf bi.Client_baking_blocks.hash)) bis - >>= fun () -> - insert_blocks cctxt ?max_priority state bis >>= fun () -> - worker_loop () + >>= fun () -> + insert_blocks cctxt ?max_priority state bis >>= fun () -> + worker_loop () end | `Endorsement (Some (Ok e)) -> Lwt.cancel timeout ; @@ -617,6 +617,6 @@ let create Lwt.return_unit end >>= fun () -> worker_loop () in - lwt_log_info "Starting baking daemon" >>= fun () -> - worker_loop () >>= fun () -> - return () + lwt_log_info "Starting baking daemon" >>= fun () -> + worker_loop () >>= fun () -> + return () diff --git a/src/client/embedded/alpha/client_baking_main.ml b/src/client/embedded/alpha/client_baking_main.ml index 919d1ee6f..bf3d2ab04 100644 --- a/src/client/embedded/alpha/client_baking_main.ml +++ b/src/client/embedded/alpha/client_baking_main.ml @@ -109,7 +109,7 @@ let commands () = [ command ~group ~desc: "Launch a daemon that handles delegate operations." (args5 max_priority_arg endorsement_delay_arg - Daemon.baking_switch Daemon.endorsement_switch Daemon.denunciation_switch) + Daemon.baking_switch Daemon.endorsement_switch Daemon.denunciation_switch) (prefixes [ "launch" ; "daemon" ] @@ seq_of_param Client_keys.Public_key_hash.alias_param) (fun (max_priority, endorsement_delay, baking, endorsement, denunciation) delegates cctxt -> diff --git a/src/client/embedded/alpha/client_baking_operations.ml b/src/client/embedded/alpha/client_baking_operations.ml index 2aadf97b4..c739ccd2a 100644 --- a/src/client/embedded/alpha/client_baking_operations.ml +++ b/src/client/embedded/alpha/client_baking_operations.ml @@ -28,7 +28,7 @@ let monitor cctxt ?contents ?check () = | [proto] -> return { hash ; content = Some proto } | _ -> failwith "Error while parsing the operation") - (List.concat ops) + (List.concat ops) in return (Lwt_stream.map_s convert ops_stream) diff --git a/src/client/embedded/alpha/client_proto_contracts.ml b/src/client/embedded/alpha/client_proto_contracts.ml index 32143eba0..a6fc53a88 100644 --- a/src/client/embedded/alpha/client_proto_contracts.ml +++ b/src/client/embedded/alpha/client_proto_contracts.ml @@ -101,10 +101,10 @@ module ContractAlias = struct end))) next - let name cctxt contract = - rev_find cctxt contract >>=? function - | None -> return (Contract.to_b58check contract) - | Some name -> return name + let name cctxt contract = + rev_find cctxt contract >>=? function + | None -> return (Contract.to_b58check contract) + | Some name -> return name end diff --git a/src/client/embedded/alpha/client_proto_nonces.ml b/src/client/embedded/alpha/client_proto_nonces.ml index be13dd4c5..0e259a745 100644 --- a/src/client/embedded/alpha/client_proto_nonces.ml +++ b/src/client/embedded/alpha/client_proto_nonces.ml @@ -68,7 +68,7 @@ let find cctxt block_hash = let add cctxt block_hash nonce = load cctxt >>= fun data -> save cctxt ((block_hash, nonce) :: - List.remove_assoc block_hash data) + List.remove_assoc block_hash data) let del cctxt block_hash = load cctxt >>= fun data -> diff --git a/src/client/embedded/alpha/client_proto_rpcs.ml b/src/client/embedded/alpha/client_proto_rpcs.ml index 1e228d535..e03b0d923 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.ml +++ b/src/client/embedded/alpha/client_proto_rpcs.ml @@ -176,11 +176,11 @@ module Helpers = struct let baking_rights_for_delegate cctxt b c ?max_priority ?first_level ?last_level () = call_error_service2 cctxt Services.Helpers.Rights.baking_rights_for_delegate - b c (max_priority, first_level, last_level) + b c (max_priority, first_level, last_level) let endorsement_rights_for_delegate cctxt b c ?max_priority ?first_level ?last_level () = - call_error_service2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate - b c (max_priority, first_level, last_level) + call_error_service2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate + b c (max_priority, first_level, last_level) end module Forge = struct @@ -246,10 +246,10 @@ module Helpers = struct ({net_id ; branch}, Sourced_operations op)) let activate cctxt b ~net_id ~branch hash = - operation cctxt b ~net_id ~branch (Activate hash) + operation cctxt b ~net_id ~branch (Activate hash) let activate_testnet cctxt b ~net_id ~branch hash = - operation cctxt b ~net_id ~branch (Activate_testnet hash) + operation cctxt b ~net_id ~branch (Activate_testnet hash) end module Anonymous = struct let operations cctxt block ~net_id ~branch operations = @@ -286,11 +286,11 @@ module Helpers = struct end (* type slot = *) - (* raw_level * int * timestamp option *) - (* let baking_possibilities *) - (* b c ?max_priority ?first_level ?last_level () = *) - (* call_error_service2 Services.Helpers.Context.Contract.baking_possibilities *) - (* b c (max_priority, first_level, last_level) *) - (* (\* let endorsement_possibilities b c ?max_priority ?first_level ?last_level () = *\) *) - (* call_error_service2 Services.Helpers.Context.Contract.endorsement_possibilities *) - (* b c (max_priority, first_level, last_level) *) +(* raw_level * int * timestamp option *) +(* let baking_possibilities *) +(* b c ?max_priority ?first_level ?last_level () = *) +(* call_error_service2 Services.Helpers.Context.Contract.baking_possibilities *) +(* b c (max_priority, first_level, last_level) *) +(* (\* let endorsement_possibilities b c ?max_priority ?first_level ?last_level () = *\) *) +(* call_error_service2 Services.Helpers.Context.Contract.endorsement_possibilities *) +(* b c (max_priority, first_level, last_level) *) diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index 43999f42f..5604a1d01 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -73,15 +73,15 @@ module Context : sig module Nonce : sig val hash: - Client_rpcs.config -> - block -> Nonce_hash.t tzresult Lwt.t + Client_rpcs.config -> + block -> Nonce_hash.t tzresult Lwt.t type nonce_info = | Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten val get: - Client_rpcs.config -> - block -> Raw_level.t -> nonce_info tzresult Lwt.t + Client_rpcs.config -> + block -> Raw_level.t -> nonce_info tzresult Lwt.t end module Key : sig val get : @@ -95,8 +95,8 @@ module Context : sig end module Contract : sig val list: - Client_rpcs.config -> - block -> Contract.t list tzresult Lwt.t + Client_rpcs.config -> + block -> Contract.t list tzresult Lwt.t type info = { manager: public_key_hash ; balance: Tez.t ; diff --git a/src/client/embedded/alpha/michelson_macros.ml b/src/client/embedded/alpha/michelson_macros.ml index cc164f8db..dd6653b97 100644 --- a/src/client/embedded/alpha/michelson_macros.ml +++ b/src/client/embedded/alpha/michelson_macros.ml @@ -386,11 +386,11 @@ let expand_asserts original = | _ -> begin match expand_compare remaining_prim with - | None -> None - | Some seq -> - Some (Seq (loc, [ seq ; - Prim (loc, "IF", fail_false loc, None) ], None)) - end + | None -> None + | Some seq -> + Some (Seq (loc, [ seq ; + Prim (loc, "IF", fail_false loc, None) ], None)) + end end | _ -> None @@ -618,11 +618,11 @@ let unexpand_unpaaiair expanded = | Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest -> destruct ("A" :: sacc) acc (sub :: rest) | Seq (_, [ Prim (_, "DUP", [], None) ; - Prim (_, "CAR", [], None) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CDR", [], None) ], None) ], - None) ], None) :: rest -> + Prim (_, "CAR", [], None) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CDR", [], None) ], None) ], + None) ], None) :: rest -> destruct [] (List.rev ("AI" :: sacc) :: acc) rest | _ -> None in begin match destruct [] [ [ "R" ] ] nodes with diff --git a/src/compiler/native.ml b/src/compiler/native.ml index 22a9c1a50..b259b4326 100644 --- a/src/compiler/native.ml +++ b/src/compiler/native.ml @@ -101,7 +101,7 @@ let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis the protocol first-class module into the [Updater.versions] hashtable). - *) +*) let tezos_protocol_env = diff --git a/src/environment/v1/array.mli b/src/environment/v1/array.mli index 03a5e0567..78e941458 100644 --- a/src/environment/v1/array.mli +++ b/src/environment/v1/array.mli @@ -28,33 +28,33 @@ external length : 'a array -> int = "%array_length" external get : 'a array -> int -> 'a = "%array_safe_get" (** [Array.get a n] returns the element number [n] of array [a]. - The first element has number 0. - The last element has number [Array.length a - 1]. - You can also write [a.(n)] instead of [Array.get a n]. + The first element has number 0. + The last element has number [Array.length a - 1]. + You can also write [a.(n)] instead of [Array.get a n]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(Array.length a - 1)]. *) + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(Array.length a - 1)]. *) external set : 'a array -> int -> 'a -> unit = "%array_safe_set" (** [Array.set a n x] modifies array [a] in place, replacing - element number [n] with [x]. - You can also write [a.(n) <- x] instead of [Array.set a n x]. + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [Array.set a n x]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [Array.length a - 1]. *) + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [Array.length a - 1]. *) external make : int -> 'a -> 'a array = "caml_make_vect" (** [Array.make n x] returns a fresh array of length [n], - initialized with [x]. - All the elements of this new array are initially - physically equal to [x] (in the sense of the [==] predicate). - Consequently, if [x] is mutable, it is shared among all elements - of the array, and modifying [x] through one of the array entries - will modify all other entries at the same time. + initialized with [x]. + All the elements of this new array are initially + physically equal to [x] (in the sense of the [==] predicate). + Consequently, if [x] is mutable, it is shared among all elements + of the array, and modifying [x] through one of the array entries + will modify all other entries at the same time. - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. - If the value of [x] is a floating-point number, then the maximum - size is only [Sys.max_array_length / 2].*) + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the value of [x] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2].*) external create_float: int -> float array = "caml_make_float_vect" (** [Array.create_float n] returns a fresh float array of length [n], @@ -63,71 +63,71 @@ external create_float: int -> float array = "caml_make_float_vect" val init : int -> (int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], - with element number [i] initialized to the result of [f i]. - In other terms, [Array.init n f] tabulates the results of [f] - applied to the integers [0] to [n-1]. + with element number [i] initialized to the result of [f i]. + In other terms, [Array.init n f] tabulates the results of [f] + applied to the integers [0] to [n-1]. - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. - If the return type of [f] is [float], then the maximum - size is only [Sys.max_array_length / 2].*) + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the return type of [f] is [float], then the maximum + size is only [Sys.max_array_length / 2].*) val make_matrix : int -> int -> 'a -> 'a array array (** [Array.make_matrix dimx dimy e] returns a two-dimensional array - (an array of arrays) with first dimension [dimx] and - second dimension [dimy]. All the elements of this new matrix - are initially physically equal to [e]. - The element ([x,y]) of a matrix [m] is accessed - with the notation [m.(x).(y)]. + (an array of arrays) with first dimension [dimx] and + second dimension [dimy]. All the elements of this new matrix + are initially physically equal to [e]. + The element ([x,y]) of a matrix [m] is accessed + with the notation [m.(x).(y)]. - Raise [Invalid_argument] if [dimx] or [dimy] is negative or - greater than [Sys.max_array_length]. - If the value of [e] is a floating-point number, then the maximum - size is only [Sys.max_array_length / 2]. *) + Raise [Invalid_argument] if [dimx] or [dimy] is negative or + greater than [Sys.max_array_length]. + If the value of [e] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2]. *) val append : 'a array -> 'a array -> 'a array (** [Array.append v1 v2] returns a fresh array containing the - concatenation of the arrays [v1] and [v2]. *) + concatenation of the arrays [v1] and [v2]. *) val concat : 'a array list -> 'a array (** Same as [Array.append], but concatenates a list of arrays. *) val sub : 'a array -> int -> int -> 'a array (** [Array.sub a start len] returns a fresh array of length [len], - containing the elements number [start] to [start + len - 1] - of array [a]. + containing the elements number [start] to [start + len - 1] + of array [a]. - Raise [Invalid_argument "Array.sub"] if [start] and [len] do not - designate a valid subarray of [a]; that is, if - [start < 0], or [len < 0], or [start + len > Array.length a]. *) + Raise [Invalid_argument "Array.sub"] if [start] and [len] do not + designate a valid subarray of [a]; that is, if + [start < 0], or [len < 0], or [start + len > Array.length a]. *) val copy : 'a array -> 'a array (** [Array.copy a] returns a copy of [a], that is, a fresh array - containing the same elements as [a]. *) + containing the same elements as [a]. *) val fill : 'a array -> int -> int -> 'a -> unit (** [Array.fill a ofs len x] modifies the array [a] in place, - storing [x] in elements number [ofs] to [ofs + len - 1]. + storing [x] in elements number [ofs] to [ofs + len - 1]. - Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not - designate a valid subarray of [a]. *) + Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not + designate a valid subarray of [a]. *) val blit : 'a array -> int -> 'a array -> int -> int -> unit (** [Array.blit v1 o1 v2 o2 len] copies [len] elements - from array [v1], starting at element number [o1], to array [v2], - starting at element number [o2]. It works correctly even if - [v1] and [v2] are the same array, and the source and - destination chunks overlap. + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. - Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not - designate a valid subarray of [v1], or if [o2] and [len] do not - designate a valid subarray of [v2]. *) + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) val to_list : 'a array -> 'a list (** [Array.to_list a] returns the list of all the elements of [a]. *) val of_list : 'a list -> 'a array (** [Array.of_list l] returns a fresh array containing the elements - of [l]. *) + of [l]. *) (** {6 Iterators} *) @@ -135,33 +135,33 @@ val of_list : 'a list -> 'a array val iter : ('a -> unit) -> 'a array -> unit (** [Array.iter f a] applies function [f] in turn to all - the elements of [a]. It is equivalent to - [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) val iteri : (int -> 'a -> unit) -> 'a array -> unit (** Same as {!Array.iter}, but the - function is applied with the index of the element as first argument, - and the element itself as second argument. *) + function is applied with the index of the element as first argument, + and the element itself as second argument. *) val map : ('a -> 'b) -> 'a array -> 'b array (** [Array.map f a] applies function [f] to all the elements of [a], - and builds an array with the results returned by [f]: - [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) + and builds an array with the results returned by [f]: + [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array (** Same as {!Array.map}, but the - function is applied to the index of the element as first argument, - and the element itself as second argument. *) + function is applied to the index of the element as first argument, + and the element itself as second argument. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a (** [Array.fold_left f x a] computes - [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], - where [n] is the length of the array [a]. *) + [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a (** [Array.fold_right f a x] computes - [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], - where [n] is the length of the array [a]. *) + [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], + where [n] is the length of the array [a]. *) (** {6 Iterators on two arrays} *) @@ -169,16 +169,16 @@ val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (** [Array.iter2 f a b] applies function [f] to all the elements of [a] - and [b]. - Raise [Invalid_argument] if the arrays are not the same size. - @since 4.03.0 *) + and [b]. + Raise [Invalid_argument] if the arrays are not the same size. + @since 4.03.0 *) val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array (** [Array.map2 f a b] applies function [f] to all the elements of [a] - and [b], and builds an array with the results returned by [f]: - [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]]. - Raise [Invalid_argument] if the arrays are not the same size. - @since 4.03.0 *) + and [b], and builds an array with the results returned by [f]: + [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]]. + Raise [Invalid_argument] if the arrays are not the same size. + @since 4.03.0 *) (** {6 Array scanning} *) @@ -186,9 +186,9 @@ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val for_all : ('a -> bool) -> 'a array -> bool (** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array - satisfy the predicate [p]. That is, it returns - [(p a1) && (p a2) && ... && (p an)]. - @since 4.03.0 *) + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. + @since 4.03.0 *) val exists : ('a -> bool) -> 'a array -> bool (** [Array.exists p [|a1; ...; an|]] checks if at least one element of @@ -198,13 +198,13 @@ val exists : ('a -> bool) -> 'a array -> bool val mem : 'a -> 'a array -> bool (** [mem a l] is true if and only if [a] is equal - to an element of [l]. - @since 4.03.0 *) + to an element of [l]. + @since 4.03.0 *) val memq : 'a -> 'a array -> bool (** Same as {!Array.mem}, but uses physical equality instead of structural - equality to compare array elements. - @since 4.03.0 *) + equality to compare array elements. + @since 4.03.0 *) (** {6 Sorting} *) @@ -212,38 +212,38 @@ val memq : 'a -> 'a array -> bool val sort : ('a -> 'a -> int) -> 'a array -> unit (** Sort an array in increasing order according to a comparison - function. The comparison function must return 0 if its arguments - compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller (see below for a - complete specification). For example, {!Pervasives.compare} is - a suitable comparison function, provided there are no floating-point - NaN values in the data. After calling [Array.sort], the - array is sorted in place in increasing order. - [Array.sort] is guaranteed to run in constant heap space - and (at most) logarithmic stack space. + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see below for a + complete specification). For example, {!Pervasives.compare} is + a suitable comparison function, provided there are no floating-point + NaN values in the data. After calling [Array.sort], the + array is sorted in place in increasing order. + [Array.sort] is guaranteed to run in constant heap space + and (at most) logarithmic stack space. - The current implementation uses Heap Sort. It runs in constant - stack space. + The current implementation uses Heap Sort. It runs in constant + stack space. - Specification of the comparison function: - Let [a] be the array and [cmp] the comparison function. The following - must be true for all x, y, z in a : -- [cmp x y] > 0 if and only if [cmp y x] < 0 -- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 + Specification of the comparison function: + Let [a] be the array and [cmp] the comparison function. The following + must be true for all x, y, z in a : + - [cmp x y] > 0 if and only if [cmp y x] < 0 + - if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 - When [Array.sort] returns, [a] contains the same elements as before, - reordered in such a way that for all i and j valid indices of [a] : -- [cmp a.(i) a.(j)] >= 0 if and only if i >= j + When [Array.sort] returns, [a] contains the same elements as before, + reordered in such a way that for all i and j valid indices of [a] : + - [cmp a.(i) a.(j)] >= 0 if and only if i >= j *) val stable_sort : ('a -> 'a -> int) -> 'a array -> unit (** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. - elements that compare equal are kept in their original order) and - not guaranteed to run in constant heap space. + elements that compare equal are kept in their original order) and + not guaranteed to run in constant heap space. - The current implementation uses Merge Sort. It uses [n/2] - words of heap space, where [n] is the length of the array. - It is usually faster than the current implementation of {!Array.sort}. + The current implementation uses Merge Sort. It uses [n/2] + words of heap space, where [n] is the length of the array. + It is usually faster than the current implementation of {!Array.sort}. *) val fast_sort : ('a -> 'a -> int) -> 'a array -> unit diff --git a/src/environment/v1/buffer.mli b/src/environment/v1/buffer.mli index dde414691..c06c4cec3 100644 --- a/src/environment/v1/buffer.mli +++ b/src/environment/v1/buffer.mli @@ -22,10 +22,10 @@ (** Extensible buffers. - This module implements buffers that automatically expand - as necessary. It provides accumulative concatenation of strings - in quasi-linear time (instead of quadratic time when strings are - concatenated pairwise). + This module implements buffers that automatically expand + as necessary. It provides accumulative concatenation of strings + in quasi-linear time (instead of quadratic time when strings are + concatenated pairwise). *) type t @@ -33,17 +33,17 @@ type t val create : int -> t (** [create n] returns a fresh buffer, initially empty. - The [n] parameter is the initial size of the internal byte sequence - that holds the buffer contents. That byte sequence is automatically - reallocated when more than [n] characters are stored in the buffer, - but shrinks back to [n] characters when [reset] is called. - For best performance, [n] should be of the same order of magnitude - as the number of characters that are expected to be stored in - the buffer (for instance, 80 for a buffer that holds one output - line). Nothing bad will happen if the buffer grows beyond that - limit, however. In doubt, take [n = 16] for instance. - If [n] is not between 1 and {!Sys.max_string_length}, it will - be clipped to that interval. *) + The [n] parameter is the initial size of the internal byte sequence + that holds the buffer contents. That byte sequence is automatically + reallocated when more than [n] characters are stored in the buffer, + but shrinks back to [n] characters when [reset] is called. + For best performance, [n] should be of the same order of magnitude + as the number of characters that are expected to be stored in + the buffer (for instance, 80 for a buffer that holds one output + line). Nothing bad will happen if the buffer grows beyond that + limit, however. In doubt, take [n = 16] for instance. + If [n] is not between 1 and {!Sys.max_string_length}, it will + be clipped to that interval. *) val contents : t -> string (** Return a copy of the current contents of the buffer. @@ -63,13 +63,13 @@ val sub : t -> int -> int -> string val blit : t -> int -> bytes -> int -> int -> unit (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from - the current contents of the buffer [src], starting at offset [srcoff] - to [dst], starting at character [dstoff]. + the current contents of the buffer [src], starting at offset [srcoff] + to [dst], starting at character [dstoff]. - Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid - range of [src], or if [dstoff] and [len] do not designate a valid - range of [dst]. - @since 3.11.2 + Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid + range of [src], or if [dstoff] and [len] do not designate a valid + range of [dst]. + @since 3.11.2 *) val nth : t -> int -> char @@ -84,10 +84,10 @@ val clear : t -> unit val reset : t -> unit (** Empty the buffer and deallocate the internal byte sequence holding the - buffer contents, replacing it with the initial internal byte sequence - of length [n] that was allocated by {!Buffer.create} [n]. - For long-lived buffers that may have grown a lot, [reset] allows - faster reclamation of the space used by the buffer. *) + buffer contents, replacing it with the initial internal byte sequence + of length [n] that was allocated by {!Buffer.create} [n]. + For long-lived buffers that may have grown a lot, [reset] allows + faster reclamation of the space used by the buffer. *) val add_char : t -> char -> unit (** [add_char b c] appends the character [c] at the end of buffer [b]. *) @@ -101,7 +101,7 @@ val add_bytes : t -> bytes -> unit val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset - [ofs] in string [s] and appends them at the end of buffer [b]. *) + [ofs] in string [s] and appends them at the end of buffer [b]. *) val add_subbytes : t -> bytes -> int -> int -> unit (** [add_subbytes b s ofs len] takes [len] characters from offset @@ -110,20 +110,20 @@ val add_subbytes : t -> bytes -> int -> int -> unit val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end - of buffer [b] with substitution. - The substitution process looks for variables into - the pattern and substitutes each variable name by its value, as - obtained by applying the mapping [f] to the variable name. Inside the - string pattern, a variable name immediately follows a non-escaped - [$] character and is one of the following: - - a non empty sequence of alphanumeric or [_] characters, - - an arbitrary sequence of characters enclosed by a pair of - matching parentheses or curly brackets. - An escaped [$] character is a [$] that immediately follows a backslash - character; it then stands for a plain [$]. - Raise [Not_found] if the closing character of a parenthesized variable - cannot be found. *) + of buffer [b] with substitution. + The substitution process looks for variables into + the pattern and substitutes each variable name by its value, as + obtained by applying the mapping [f] to the variable name. Inside the + string pattern, a variable name immediately follows a non-escaped + [$] character and is one of the following: + - a non empty sequence of alphanumeric or [_] characters, + - an arbitrary sequence of characters enclosed by a pair of + matching parentheses or curly brackets. + An escaped [$] character is a [$] that immediately follows a backslash + character; it then stands for a plain [$]. + Raise [Not_found] if the closing character of a parenthesized variable + cannot be found. *) val add_buffer : t -> t -> unit (** [add_buffer b1 b2] appends the current contents of buffer [b2] - at the end of buffer [b1]. [b2] is not modified. *) + at the end of buffer [b1]. [b2] is not modified. *) diff --git a/src/environment/v1/bytes.mli b/src/environment/v1/bytes.mli index 539e9d01d..2c22b35da 100644 --- a/src/environment/v1/bytes.mli +++ b/src/environment/v1/bytes.mli @@ -24,32 +24,32 @@ (** Byte sequence operations. - A byte sequence is a mutable data structure that contains a - fixed-length sequence of bytes. Each byte can be indexed in - constant time for reading or writing. + A byte sequence is a mutable data structure that contains a + fixed-length sequence of bytes. Each byte can be indexed in + constant time for reading or writing. - Given a byte sequence [s] of length [l], we can access each of the - [l] bytes of [s] via its index in the sequence. Indexes start at - [0], and we will call an index valid in [s] if it falls within the - range [[0...l-1]] (inclusive). A position is the point between two - bytes or at the beginning or end of the sequence. We call a - position valid in [s] if it falls within the range [[0...l]] - (inclusive). Note that the byte at index [n] is between positions - [n] and [n+1]. + Given a byte sequence [s] of length [l], we can access each of the + [l] bytes of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + bytes or at the beginning or end of the sequence. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the byte at index [n] is between positions + [n] and [n+1]. - Two parameters [start] and [len] are said to designate a valid - range of [s] if [len >= 0] and [start] and [start+len] are valid - positions in [s]. + Two parameters [start] and [len] are said to designate a valid + range of [s] if [len >= 0] and [start] and [start+len] are valid + positions in [s]. - Byte sequences can be modified in place, for instance via the [set] - and [blit] functions described below. See also strings (module - {!String}), which are almost the same data structure, but cannot be - modified in place. + Byte sequences can be modified in place, for instance via the [set] + and [blit] functions described below. See also strings (module + {!String}), which are almost the same data structure, but cannot be + modified in place. - Bytes are represented by the OCaml type [char]. + Bytes are represented by the OCaml type [char]. - @since 4.02.0 - *) + @since 4.02.0 +*) external length : bytes -> int = "%bytes_length" (** Return the length (number of bytes) of the argument. *) @@ -243,23 +243,23 @@ val rcontains_from : bytes -> int -> char -> bool val uppercase_ascii : bytes -> bytes (** Return a copy of the argument, with all lowercase letters - translated to uppercase, using the US-ASCII character set. - @since 4.03.0 *) + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) val lowercase_ascii : bytes -> bytes (** Return a copy of the argument, with all uppercase letters - translated to lowercase, using the US-ASCII character set. - @since 4.03.0 *) + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) val capitalize_ascii : bytes -> bytes (** Return a copy of the argument, with the first character set to uppercase, - using the US-ASCII character set. - @since 4.03.0 *) + using the US-ASCII character set. + @since 4.03.0 *) val uncapitalize_ascii : bytes -> bytes (** Return a copy of the argument, with the first character set to lowercase, - using the US-ASCII character set. - @since 4.03.0 *) + using the US-ASCII character set. + @since 4.03.0 *) type t = bytes (** An alias for the type of byte sequences. *) diff --git a/src/environment/v1/format.mli b/src/environment/v1/format.mli index 6c12319da..ca6d447ee 100644 --- a/src/environment/v1/format.mli +++ b/src/environment/v1/format.mli @@ -24,63 +24,63 @@ (** Pretty printing. - This module implements a pretty-printing facility to format values - within 'pretty-printing boxes'. The pretty-printer splits lines - at specified break hints, and indents lines according to the box - structure. + This module implements a pretty-printing facility to format values + within 'pretty-printing boxes'. The pretty-printer splits lines + at specified break hints, and indents lines according to the box + structure. - For a gentle introduction to the basics of pretty-printing using - [Format], read - {{:http://caml.inria.fr/resources/doc/guides/format.en.html} + For a gentle introduction to the basics of pretty-printing using + [Format], read + {{:http://caml.inria.fr/resources/doc/guides/format.en.html} http://caml.inria.fr/resources/doc/guides/format.en.html}. - You may consider this module as providing an extension to the - [printf] facility to provide automatic line splitting. The addition of - pretty-printing annotations to your regular [printf] formats gives you - fancy indentation and line breaks. - Pretty-printing annotations are described below in the documentation of - the function {!Format.fprintf}. + You may consider this module as providing an extension to the + [printf] facility to provide automatic line splitting. The addition of + pretty-printing annotations to your regular [printf] formats gives you + fancy indentation and line breaks. + Pretty-printing annotations are described below in the documentation of + the function {!Format.fprintf}. - You may also use the explicit box management and printing functions - provided by this module. This style is more basic but more verbose - than the [fprintf] concise formats. + You may also use the explicit box management and printing functions + provided by this module. This style is more basic but more verbose + than the [fprintf] concise formats. - For instance, the sequence - [open_box 0; print_string "x ="; print_space (); + For instance, the sequence + [open_box 0; print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()] - that prints [x = 1] within a pretty-printing box, can be - abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter - [printf "@[x =@ %i@]@." 1]. + that prints [x = 1] within a pretty-printing box, can be + abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter + [printf "@[x =@ %i@]@." 1]. - Rule of thumb for casual users of this library: - - use simple boxes (as obtained by [open_box 0]); - - use simple break hints (as obtained by [print_cut ()] that outputs a - simple break hint, or by [print_space ()] that outputs a space - indicating a break hint); - - once a box is opened, display its material with basic printing - functions (e. g. [print_int] and [print_string]); - - when the material for a box has been printed, call [close_box ()] to - close the box; - - at the end of your routine, flush the pretty-printer to display all the - remaining material, e.g. evaluate [print_newline ()]. + Rule of thumb for casual users of this library: + - use simple boxes (as obtained by [open_box 0]); + - use simple break hints (as obtained by [print_cut ()] that outputs a + simple break hint, or by [print_space ()] that outputs a space + indicating a break hint); + - once a box is opened, display its material with basic printing + functions (e. g. [print_int] and [print_string]); + - when the material for a box has been printed, call [close_box ()] to + close the box; + - at the end of your routine, flush the pretty-printer to display all the + remaining material, e.g. evaluate [print_newline ()]. - The behaviour of pretty-printing commands is unspecified - if there is no opened pretty-printing box. Each box opened via - one of the [open_] functions below must be closed using [close_box] - for proper formatting. Otherwise, some of the material printed in the - boxes may not be output, or may be formatted incorrectly. + The behaviour of pretty-printing commands is unspecified + if there is no opened pretty-printing box. Each box opened via + one of the [open_] functions below must be closed using [close_box] + for proper formatting. Otherwise, some of the material printed in the + boxes may not be output, or may be formatted incorrectly. - In case of interactive use, the system closes all opened boxes and - flushes all pending text (as with the [print_newline] function) - after each phrase. Each phrase is therefore executed in the initial - state of the pretty-printer. + In case of interactive use, the system closes all opened boxes and + flushes all pending text (as with the [print_newline] function) + after each phrase. Each phrase is therefore executed in the initial + state of the pretty-printer. - Warning: the material output by the following functions is delayed - in the pretty-printer queue in order to compute the proper line - splitting. Hence, you should not mix calls to the printing functions - of the basic I/O system with calls to the functions of this module: - this could result in some strange output seemingly unrelated with - the evaluation order of printing commands. + Warning: the material output by the following functions is delayed + in the pretty-printer queue in order to compute the proper line + splitting. Hence, you should not mix calls to the printing functions + of the basic I/O system with calls to the functions of this module: + this could result in some strange output seemingly unrelated with + the evaluation order of printing commands. *) (** {6:tags Semantic Tags} *) @@ -90,9 +90,9 @@ type tag = string (** {6:meaning Changing the meaning of standard formatter pretty printing} *) (** The [Format] module is versatile enough to let you completely redefine - the meaning of pretty printing: you may provide your own functions to define - how to handle indentation, line splitting, and even printing of all the - characters that have to be printed! *) + the meaning of pretty printing: you may provide your own functions to define + how to handle indentation, line splitting, and even printing of all the + characters that have to be printed! *) type formatter_out_functions = { out_string : string -> int -> int -> unit; @@ -110,44 +110,44 @@ type formatter_tag_functions = { print_close_tag : tag -> unit; } (** The tag handling functions specific to a formatter: - [mark] versions are the 'tag marking' functions that associate a string - marker to a tag in order for the pretty-printing engine to flush - those markers as 0 length tokens in the output device of the formatter. - [print] versions are the 'tag printing' functions that can perform - regular printing when a tag is closed or opened. *) + [mark] versions are the 'tag marking' functions that associate a string + marker to a tag in order for the pretty-printing engine to flush + those markers as 0 length tokens in the output device of the formatter. + [print] versions are the 'tag printing' functions that can perform + regular printing when a tag is closed or opened. *) (** {6 Multiple formatted output} *) type formatter (** Abstract data corresponding to a pretty-printer (also called a - formatter) and all its machinery. + formatter) and all its machinery. - Defining new pretty-printers permits unrelated output of material in - parallel on several output channels. - All the parameters of a pretty-printer are local to a formatter: - margin, maximum indentation limit, maximum number of boxes - simultaneously opened, ellipsis, and so on, are specific to - each pretty-printer and may be fixed independently. - Given a [Pervasives.out_channel] output channel [oc], a new formatter - writing to that channel is simply obtained by calling - [formatter_of_out_channel oc]. - Alternatively, the [make_formatter] function allocates a new - formatter with explicit output and flushing functions - (convenient to output material to strings for instance). + Defining new pretty-printers permits unrelated output of material in + parallel on several output channels. + All the parameters of a pretty-printer are local to a formatter: + margin, maximum indentation limit, maximum number of boxes + simultaneously opened, ellipsis, and so on, are specific to + each pretty-printer and may be fixed independently. + Given a [Pervasives.out_channel] output channel [oc], a new formatter + writing to that channel is simply obtained by calling + [formatter_of_out_channel oc]. + Alternatively, the [make_formatter] function allocates a new + formatter with explicit output and flushing functions + (convenient to output material to strings for instance). *) val formatter_of_buffer : Buffer.t -> formatter (** [formatter_of_buffer b] returns a new formatter writing to - buffer [b]. As usual, the formatter has to be flushed at - the end of pretty printing, using [pp_print_flush] or - [pp_print_newline], to display all the pending material. *) + buffer [b]. As usual, the formatter has to be flushed at + the end of pretty printing, using [pp_print_flush] or + [pp_print_newline], to display all the pending material. *) val make_formatter : (string -> int -> int -> unit) -> (unit -> unit) -> formatter (** [make_formatter out flush] returns a new formatter that writes according - to the output function [out], and the flushing function [flush]. For - instance, a formatter to the [Pervasives.out_channel] [oc] is returned by - [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) + to the output function [out], and the flushing function [flush]. For + instance, a formatter to the [Pervasives.out_channel] [oc] is returned by + [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) (** {6 Basic functions to use with formatters} *) @@ -205,9 +205,9 @@ val pp_set_formatter_out_functions : val pp_get_formatter_out_functions : formatter -> unit -> formatter_out_functions (** These functions are the basic ones: usual functions - operating on the standard formatter are defined via partial - evaluation of these primitives. For instance, - [print_string] is equal to [pp_print_string std_formatter]. *) + operating on the standard formatter are defined via partial + evaluation of these primitives. For instance, + [print_string] is equal to [pp_print_string std_formatter]. *) val pp_flush_formatter : formatter -> unit (** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all @@ -223,19 +223,19 @@ val pp_print_list: ?pp_sep:(formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit) (** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l], - using [pp_v] to print each item, and calling [pp_sep] - between items ([pp_sep] defaults to {!pp_print_cut}). - Does nothing on empty lists. + using [pp_v] to print each item, and calling [pp_sep] + between items ([pp_sep] defaults to {!pp_print_cut}). + Does nothing on empty lists. - @since 4.02.0 + @since 4.02.0 *) val pp_print_text : formatter -> string -> unit (** [pp_print_text ppf s] prints [s] with spaces and newlines - respectively printed with {!pp_print_space} and - {!pp_force_newline}. + respectively printed with {!pp_print_space} and + {!pp_force_newline}. - @since 4.02.0 + @since 4.02.0 *) (** {6 [printf] like functions for pretty-printing.} *) @@ -243,17 +243,17 @@ val pp_print_text : formatter -> string -> unit val fprintf : formatter -> ('a, formatter, unit) format -> 'a (** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] - according to the format string [fmt], and outputs the resulting string on - the formatter [ff]. + according to the format string [fmt], and outputs the resulting string on + the formatter [ff]. - The format [fmt] is a character string which contains three types of - objects: plain characters and conversion specifications as specified in - the [Printf] module, and pretty-printing indications specific to the - [Format] module. + The format [fmt] is a character string which contains three types of + objects: plain characters and conversion specifications as specified in + the [Printf] module, and pretty-printing indications specific to the + [Format] module. - The pretty-printing indication characters are introduced by - a [@] character, and their meanings are: - - [@\[]: open a pretty-printing box. The type and offset of the + The pretty-printing indication characters are introduced by + a [@] character, and their meanings are: + - [@\[]: open a pretty-printing box. The type and offset of the box may be optionally specified with the following syntax: the [<] character, followed by an optional box type indication, then an optional integer offset, and the closing [>] character. @@ -267,24 +267,24 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a box with indentation 2 as obtained with [open_hovbox 2]. For more details about boxes, see the various box opening functions [open_*box]. - - [@\]]: close the most recently opened pretty-printing box. - - [@,]: output a 'cut' break hint, as with [print_cut ()]. - - [@ ]: output a 'space' break hint, as with [print_space ()]. - - [@;]: output a 'full' break hint as with [print_break]. The + - [@\]]: close the most recently opened pretty-printing box. + - [@,]: output a 'cut' break hint, as with [print_cut ()]. + - [@ ]: output a 'space' break hint, as with [print_space ()]. + - [@;]: output a 'full' break hint as with [print_break]. The [nspaces] and [offset] parameters of the break hint may be optionally specified with the following syntax: the [<] character, followed by an integer [nspaces] value, then an integer [offset], and a closing [>] character. If no parameters are provided, the good break defaults to a 'space' break hint. - - [@.]: flush the pretty printer and split the line, as with + - [@.]: flush the pretty printer and split the line, as with [print_newline ()]. - - [@]: print the following item as if it were of length [n]. + - [@]: print the following item as if it were of length [n]. Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string. If [@] is not followed by a conversion specification, then the following character of the format is printed as if it were of length [n]. - - [@\{]: open a tag. The name of the tag may be optionally + - [@\{]: open a tag. The name of the tag may be optionally specified with the following syntax: the [<] character, followed by an optional string specification, and the closing [>] character. The string @@ -293,53 +293,53 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a empty string. For more details about tags, see the functions [open_tag] and [close_tag]. - - [@\}]: close the most recently opened tag. - - [@?]: flush the pretty printer as with [print_flush ()]. + - [@\}]: close the most recently opened tag. + - [@?]: flush the pretty printer as with [print_flush ()]. This is equivalent to the conversion [%!]. - - [@\n]: force a newline, as with [force_newline ()], not the normal way + - [@\n]: force a newline, as with [force_newline ()], not the normal way of pretty-printing, you should prefer using break hints inside a vertical box. - Note: If you need to prevent the interpretation of a [@] character as a - pretty-printing indication, you must escape it with a [%] character. - Old quotation mode [@@] is deprecated since it is not compatible with - formatted input interpretation of character ['@']. + Note: If you need to prevent the interpretation of a [@] character as a + pretty-printing indication, you must escape it with a [%] character. + Old quotation mode [@@] is deprecated since it is not compatible with + formatted input interpretation of character ['@']. - Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to - [open_box (); print_string "x ="; print_space (); - print_int 1; close_box (); print_newline ()]. - It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box. + Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to + [open_box (); print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()]. + It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box. *) val sprintf : ('a, unit, string) format -> 'a (** Same as [printf] above, but instead of printing on a formatter, - returns a string containing the result of formatting the arguments. - Note that the pretty-printer queue is flushed at the end of {e each - call} to [sprintf]. + returns a string containing the result of formatting the arguments. + Note that the pretty-printer queue is flushed at the end of {e each + call} to [sprintf]. - In case of multiple and related calls to [sprintf] to output - material on a single string, you should consider using [fprintf] - with the predefined formatter [str_formatter] and call - [flush_str_formatter ()] to get the final result. + In case of multiple and related calls to [sprintf] to output + material on a single string, you should consider using [fprintf] + with the predefined formatter [str_formatter] and call + [flush_str_formatter ()] to get the final result. - Alternatively, you can use [Format.fprintf] with a formatter writing to a - buffer of your own: flushing the formatter and the buffer at the end of - pretty-printing returns the desired string. + Alternatively, you can use [Format.fprintf] with a formatter writing to a + buffer of your own: flushing the formatter and the buffer at the end of + pretty-printing returns the desired string. *) val asprintf : ('a, formatter, unit, string) format4 -> 'a (** Same as [printf] above, but instead of printing on a formatter, - returns a string containing the result of formatting the arguments. - The type of [asprintf] is general enough to interact nicely with [%a] - conversions. - @since 4.01.0 + returns a string containing the result of formatting the arguments. + The type of [asprintf] is general enough to interact nicely with [%a] + conversions. + @since 4.01.0 *) val ifprintf : formatter -> ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but does not print anything. - Useful to ignore some material when conditionally printing. - @since 3.10.0 + Useful to ignore some material when conditionally printing. + @since 3.10.0 *) (** Formatted output functions with continuations. *) @@ -348,22 +348,22 @@ val kfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b (** Same as [fprintf] above, but instead of returning immediately, - passes the formatter to its first argument at the end of printing. *) + passes the formatter to its first argument at the end of printing. *) val ikfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b (** Same as [kfprintf] above, but does not print anything. - Useful to ignore some material when conditionally printing. - @since 3.12.0 + Useful to ignore some material when conditionally printing. + @since 3.12.0 *) val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, - passes it to the first argument. *) + passes it to the first argument. *) val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b (** Same as [asprintf] above, but instead of returning the string, - passes it to the first argument. - @since 4.03 + passes it to the first argument. + @since 4.03 *) diff --git a/src/environment/v1/int32.mli b/src/environment/v1/int32.mli index 170a8226e..eb0933726 100644 --- a/src/environment/v1/int32.mli +++ b/src/environment/v1/int32.mli @@ -22,16 +22,16 @@ (** 32-bit integers. - This module provides operations on the type [int32] - of signed 32-bit integers. Unlike the built-in [int] type, - the type [int32] is guaranteed to be exactly 32-bit wide on all - platforms. All arithmetic operations over [int32] are taken - modulo 2{^32}. + This module provides operations on the type [int32] + of signed 32-bit integers. Unlike the built-in [int] type, + the type [int32] is guaranteed to be exactly 32-bit wide on all + platforms. All arithmetic operations over [int32] are taken + modulo 2{^32}. - Performance notice: values of type [int32] occupy more memory - space than values of type [int], and arithmetic operations on - [int32] are generally slower than those on [int]. Use [int32] - only when the application requires exact 32-bit arithmetic. *) + Performance notice: values of type [int32] occupy more memory + space than values of type [int], and arithmetic operations on + [int32] are generally slower than those on [int]. Use [int32] + only when the application requires exact 32-bit arithmetic. *) val zero : int32 (** The 32-bit integer 0. *) @@ -56,14 +56,14 @@ external mul : int32 -> int32 -> int32 = "%int32_mul" external div : int32 -> int32 -> int32 = "%int32_div" (** Integer division. Raise [Division_by_zero] if the second - argument is zero. This division rounds the real quotient of - its arguments towards zero, as specified for {!Pervasives.(/)}. *) + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) external rem : int32 -> int32 -> int32 = "%int32_mod" (** Integer remainder. If [y] is not zero, the result - of [Int32.rem x y] satisfies the following property: - [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. - If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) + of [Int32.rem x y] satisfies the following property: + [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. + If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) val succ : int32 -> int32 (** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) @@ -95,19 +95,19 @@ val lognot : int32 -> int32 external shift_left : int32 -> int -> int32 = "%int32_lsl" (** [Int32.shift_left x y] shifts [x] to the left by [y] bits. - The result is unspecified if [y < 0] or [y >= 32]. *) + The result is unspecified if [y < 0] or [y >= 32]. *) external shift_right : int32 -> int -> int32 = "%int32_asr" (** [Int32.shift_right x y] shifts [x] to the right by [y] bits. - This is an arithmetic shift: the sign bit of [x] is replicated - and inserted in the vacated bits. - The result is unspecified if [y < 0] or [y >= 32]. *) + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 32]. *) external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" (** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. - This is a logical shift: zeroes are inserted in the vacated bits - regardless of the sign of [x]. - The result is unspecified if [y < 0] or [y >= 32]. *) + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 32]. *) external of_int : int -> int32 = "%int32_of_int" (** Convert the given integer (type [int]) to a 32-bit integer @@ -115,51 +115,51 @@ external of_int : int -> int32 = "%int32_of_int" external to_int : int32 -> int = "%int32_to_int" (** Convert the given 32-bit integer (type [int32]) to an - integer (type [int]). On 32-bit platforms, the 32-bit integer - is taken modulo 2{^31}, i.e. the high-order bit is lost - during the conversion. On 64-bit platforms, the conversion - is exact. *) + integer (type [int]). On 32-bit platforms, the 32-bit integer + is taken modulo 2{^31}, i.e. the high-order bit is lost + during the conversion. On 64-bit platforms, the conversion + is exact. *) external of_float : float -> int32 = "caml_int32_of_float" "caml_int32_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given floating-point number to a 32-bit integer, - discarding the fractional part (truncate towards 0). - The result of the conversion is undefined if, after truncation, - the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) external to_float : int32 -> float = "caml_int32_to_float" "caml_int32_to_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given 32-bit integer to a floating-point number. *) external of_string : string -> int32 = "caml_int32_of_string" (** Convert the given string to a 32-bit integer. - The string is read in decimal (by default) or in hexadecimal, - octal or binary if the string begins with [0x], [0o] or [0b] - respectively. - Raise [Failure "int_of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [int32]. *) + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int32]. *) val to_string : int32 -> string (** Return the string representation of its argument, in signed decimal. *) external bits_of_float : float -> int32 = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Return the internal representation of the given float according - to the IEEE 754 floating-point 'single format' bit layout. - Bit 31 of the result represents the sign of the float; - bits 30 to 23 represent the (biased) exponent; bits 22 to 0 - represent the mantissa. *) + to the IEEE 754 floating-point 'single format' bit layout. + Bit 31 of the result represents the sign of the float; + bits 30 to 23 represent the (biased) exponent; bits 22 to 0 + represent the mantissa. *) external float_of_bits : int32 -> float = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Return the floating-point number whose internal representation, - according to the IEEE 754 floating-point 'single format' bit layout, - is the given [int32]. *) + according to the IEEE 754 floating-point 'single format' bit layout, + is the given [int32]. *) type t = int32 (** An alias for the type of 32-bit integers. *) diff --git a/src/environment/v1/int64.mli b/src/environment/v1/int64.mli index 14a7fcc8a..b32466159 100644 --- a/src/environment/v1/int64.mli +++ b/src/environment/v1/int64.mli @@ -21,16 +21,16 @@ *) (** 64-bit integers. - This module provides operations on the type [int64] of - signed 64-bit integers. Unlike the built-in [int] type, - the type [int64] is guaranteed to be exactly 64-bit wide on all - platforms. All arithmetic operations over [int64] are taken - modulo 2{^64} + This module provides operations on the type [int64] of + signed 64-bit integers. Unlike the built-in [int] type, + the type [int64] is guaranteed to be exactly 64-bit wide on all + platforms. All arithmetic operations over [int64] are taken + modulo 2{^64} - Performance notice: values of type [int64] occupy more memory - space than values of type [int], and arithmetic operations on - [int64] are generally slower than those on [int]. Use [int64] - only when the application requires exact 64-bit arithmetic. + Performance notice: values of type [int64] occupy more memory + space than values of type [int], and arithmetic operations on + [int64] are generally slower than those on [int]. Use [int64] + only when the application requires exact 64-bit arithmetic. *) val zero : int64 @@ -56,14 +56,14 @@ external mul : int64 -> int64 -> int64 = "%int64_mul" external div : int64 -> int64 -> int64 = "%int64_div" (** Integer division. Raise [Division_by_zero] if the second - argument is zero. This division rounds the real quotient of - its arguments towards zero, as specified for {!Pervasives.(/)}. *) + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) external rem : int64 -> int64 -> int64 = "%int64_mod" (** Integer remainder. If [y] is not zero, the result - of [Int64.rem x y] satisfies the following property: - [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. - If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) + of [Int64.rem x y] satisfies the following property: + [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. + If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) val succ : int64 -> int64 (** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) @@ -94,19 +94,19 @@ val lognot : int64 -> int64 external shift_left : int64 -> int -> int64 = "%int64_lsl" (** [Int64.shift_left x y] shifts [x] to the left by [y] bits. - The result is unspecified if [y < 0] or [y >= 64]. *) + The result is unspecified if [y < 0] or [y >= 64]. *) external shift_right : int64 -> int -> int64 = "%int64_asr" (** [Int64.shift_right x y] shifts [x] to the right by [y] bits. - This is an arithmetic shift: the sign bit of [x] is replicated - and inserted in the vacated bits. - The result is unspecified if [y < 0] or [y >= 64]. *) + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 64]. *) external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" (** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. - This is a logical shift: zeroes are inserted in the vacated bits - regardless of the sign of [x]. - The result is unspecified if [y < 0] or [y >= 64]. *) + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 64]. *) external of_int : int -> int64 = "%int64_of_int" (** Convert the given integer (type [int]) to a 64-bit integer @@ -114,73 +114,73 @@ external of_int : int -> int64 = "%int64_of_int" external to_int : int64 -> int = "%int64_to_int" (** Convert the given 64-bit integer (type [int64]) to an - integer (type [int]). On 64-bit platforms, the 64-bit integer - is taken modulo 2{^63}, i.e. the high-order bit is lost - during the conversion. On 32-bit platforms, the 64-bit integer - is taken modulo 2{^31}, i.e. the top 33 bits are lost - during the conversion. *) + integer (type [int]). On 64-bit platforms, the 64-bit integer + is taken modulo 2{^63}, i.e. the high-order bit is lost + during the conversion. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^31}, i.e. the top 33 bits are lost + during the conversion. *) external of_float : float -> int64 = "caml_int64_of_float" "caml_int64_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given floating-point number to a 64-bit integer, - discarding the fractional part (truncate towards 0). - The result of the conversion is undefined if, after truncation, - the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) external to_float : int64 -> float = "caml_int64_to_float" "caml_int64_to_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given 64-bit integer to a floating-point number. *) external of_int32 : int32 -> int64 = "%int64_of_int32" (** Convert the given 32-bit integer (type [int32]) - to a 64-bit integer (type [int64]). *) + to a 64-bit integer (type [int64]). *) external to_int32 : int64 -> int32 = "%int64_to_int32" (** Convert the given 64-bit integer (type [int64]) to a - 32-bit integer (type [int32]). The 64-bit integer - is taken modulo 2{^32}, i.e. the top 32 bits are lost - during the conversion. *) + 32-bit integer (type [int32]). The 64-bit integer + is taken modulo 2{^32}, i.e. the top 32 bits are lost + during the conversion. *) external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" (** Convert the given native integer (type [nativeint]) - to a 64-bit integer (type [int64]). *) + to a 64-bit integer (type [int64]). *) external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" (** Convert the given 64-bit integer (type [int64]) to a - native integer. On 32-bit platforms, the 64-bit integer - is taken modulo 2{^32}. On 64-bit platforms, - the conversion is exact. *) + native integer. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^32}. On 64-bit platforms, + the conversion is exact. *) external of_string : string -> int64 = "caml_int64_of_string" (** Convert the given string to a 64-bit integer. - The string is read in decimal (by default) or in hexadecimal, - octal or binary if the string begins with [0x], [0o] or [0b] - respectively. - Raise [Failure "int_of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [int64]. *) + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int64]. *) val to_string : int64 -> string (** Return the string representation of its argument, in decimal. *) external bits_of_float : float -> int64 = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Return the internal representation of the given float according - to the IEEE 754 floating-point 'double format' bit layout. - Bit 63 of the result represents the sign of the float; - bits 62 to 52 represent the (biased) exponent; bits 51 to 0 - represent the mantissa. *) + to the IEEE 754 floating-point 'double format' bit layout. + Bit 63 of the result represents the sign of the float; + bits 62 to 52 represent the (biased) exponent; bits 51 to 0 + represent the mantissa. *) external float_of_bits : int64 -> float = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Return the floating-point number whose internal representation, - according to the IEEE 754 floating-point 'double format' bit layout, - is the given [int64]. *) + according to the IEEE 754 floating-point 'double format' bit layout, + is the given [int64]. *) type t = int64 (** An alias for the type of 64-bit integers. *) diff --git a/src/environment/v1/list.mli b/src/environment/v1/list.mli index 7d12712a1..9111dd45f 100644 --- a/src/environment/v1/list.mli +++ b/src/environment/v1/list.mli @@ -15,15 +15,15 @@ (** List operations. - Some functions are flagged as not tail-recursive. A tail-recursive - function uses constant stack space, while a non-tail-recursive function - uses stack space proportional to the length of its list argument, which - can be a problem with very long lists. When the function takes several - list arguments, an approximate formula giving stack usage (in some - unspecified constant unit) is shown in parentheses. + Some functions are flagged as not tail-recursive. A tail-recursive + function uses constant stack space, while a non-tail-recursive function + uses stack space proportional to the length of its list argument, which + can be a problem with very long lists. When the function takes several + list arguments, an approximate formula giving stack usage (in some + unspecified constant unit) is shown in parentheses. - The above considerations can usually be ignored if your lists are not - longer than about 10000 elements. + The above considerations can usually be ignored if your lists are not + longer than about 10000 elements. *) val length : 'a list -> int @@ -36,35 +36,35 @@ val cons : 'a -> 'a list -> 'a list val hd : 'a list -> 'a (** Return the first element of the given list. Raise - [Failure "hd"] if the list is empty. *) + [Failure "hd"] if the list is empty. *) val tl : 'a list -> 'a list (** Return the given list without its first element. Raise - [Failure "tl"] if the list is empty. *) + [Failure "tl"] if the list is empty. *) val nth : 'a list -> int -> 'a (** Return the [n]-th element of the given list. - The first element (head of the list) is at position 0. - Raise [Failure "nth"] if the list is too short. - Raise [Invalid_argument "List.nth"] if [n] is negative. *) + The first element (head of the list) is at position 0. + Raise [Failure "nth"] if the list is too short. + Raise [Invalid_argument "List.nth"] if [n] is negative. *) val rev : 'a list -> 'a list (** List reversal. *) val append : 'a list -> 'a list -> 'a list (** Concatenate two lists. Same as the infix operator [@]. - Not tail-recursive (length of the first argument). *) + Not tail-recursive (length of the first argument). *) val rev_append : 'a list -> 'a list -> 'a list (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. - This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is - tail-recursive and more efficient. *) + This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is + tail-recursive and more efficient. *) val concat : 'a list list -> 'a list (** Concatenate a list of lists. The elements of the argument are all - concatenated together (in the same order) to give the result. - Not tail-recursive - (length of the argument + length of the longest sub-list). *) + concatenated together (in the same order) to give the result. + Not tail-recursive + (length of the argument + length of the longest sub-list). *) val flatten : 'a list list -> 'a list (** An alias for [concat]. *) @@ -75,40 +75,40 @@ val flatten : 'a list list -> 'a list val iter : ('a -> unit) -> 'a list -> unit (** [List.iter f [a1; ...; an]] applies function [f] in turn to - [a1; ...; an]. It is equivalent to - [begin f a1; f a2; ...; f an; () end]. *) + [a1; ...; an]. It is equivalent to + [begin f a1; f a2; ...; f an; () end]. *) val iteri : (int -> 'a -> unit) -> 'a list -> unit (** Same as {!List.iter}, but the function is applied to the index of - the element as first argument (counting from 0), and the element - itself as second argument. - @since 4.00.0 + the element as first argument (counting from 0), and the element + itself as second argument. + @since 4.00.0 *) val map : ('a -> 'b) -> 'a list -> 'b list (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], - and builds the list [[f a1; ...; f an]] - with the results returned by [f]. Not tail-recursive. *) + and builds the list [[f a1; ...; f an]] + with the results returned by [f]. Not tail-recursive. *) val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** Same as {!List.map}, but the function is applied to the index of - the element as first argument (counting from 0), and the element - itself as second argument. Not tail-recursive. - @since 4.00.0 + the element as first argument (counting from 0), and the element + itself as second argument. Not tail-recursive. + @since 4.00.0 *) val rev_map : ('a -> 'b) -> 'a list -> 'b list (** [List.rev_map f l] gives the same result as - {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and - more efficient. *) + {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and + more efficient. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a (** [List.fold_left f a [b1; ...; bn]] is - [f (... (f (f a b1) b2) ...) bn]. *) + [f (... (f (f a b1) b2) ...) bn]. *) val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b (** [List.fold_right f [a1; ...; an] b] is - [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) + [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) (** {6 Iterators on two lists} *) @@ -116,32 +116,32 @@ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn - [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. *) + [f a1 b1; ...; f an bn]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is - [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. Not tail-recursive. *) + [[f a1 b1; ...; f an bn]]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as - {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and - more efficient. *) + {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and + more efficient. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is - [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. *) + [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is - [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. Not tail-recursive. *) + [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) (** {6 List scanning} *) @@ -149,31 +149,31 @@ val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c val for_all : ('a -> bool) -> 'a list -> bool (** [for_all p [a1; ...; an]] checks if all elements of the list - satisfy the predicate [p]. That is, it returns - [(p a1) && (p a2) && ... && (p an)]. *) + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a list -> bool (** [exists p [a1; ...; an]] checks if at least one element of - the list satisfies the predicate [p]. That is, it returns - [(p a1) || (p a2) || ... || (p an)]. *) + the list satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val mem : 'a -> 'a list -> bool (** [mem a l] is true if and only if [a] is equal - to an element of [l]. *) + to an element of [l]. *) val memq : 'a -> 'a list -> bool (** Same as {!List.mem}, but uses physical equality instead of structural - equality to compare list elements. *) + equality to compare list elements. *) (** {6 List searching} *) @@ -181,24 +181,24 @@ val memq : 'a -> 'a list -> bool val find : ('a -> bool) -> 'a list -> 'a (** [find p l] returns the first element of the list [l] - that satisfies the predicate [p]. - Raise [Not_found] if there is no value that satisfies [p] in the - list [l]. *) + that satisfies the predicate [p]. + Raise [Not_found] if there is no value that satisfies [p] in the + list [l]. *) val filter : ('a -> bool) -> 'a list -> 'a list (** [filter p l] returns all the elements of the list [l] - that satisfy the predicate [p]. The order of the elements - in the input list is preserved. *) + that satisfy the predicate [p]. The order of the elements + in the input list is preserved. *) val find_all : ('a -> bool) -> 'a list -> 'a list (** [find_all] is another name for {!List.filter}. *) val partition : ('a -> bool) -> 'a list -> 'a list * 'a list (** [partition p l] returns a pair of lists [(l1, l2)], where - [l1] is the list of all the elements of [l] that - satisfy the predicate [p], and [l2] is the list of all the - elements of [l] that do not satisfy [p]. - The order of the elements in the input list is preserved. *) + [l1] is the list of all the elements of [l] that + satisfy the predicate [p], and [l2] is the list of all the + elements of [l] that do not satisfy [p]. + The order of the elements in the input list is preserved. *) (** {6 Association lists} *) @@ -206,32 +206,32 @@ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list val assoc : 'a -> ('a * 'b) list -> 'b (** [assoc a l] returns the value associated with key [a] in the list of - pairs [l]. That is, - [assoc a [ ...; (a,b); ...] = b] - if [(a,b)] is the leftmost binding of [a] in list [l]. - Raise [Not_found] if there is no value associated with [a] in the - list [l]. *) + pairs [l]. That is, + [assoc a [ ...; (a,b); ...] = b] + if [(a,b)] is the leftmost binding of [a] in list [l]. + Raise [Not_found] if there is no value associated with [a] in the + list [l]. *) val assq : 'a -> ('a * 'b) list -> 'b (** Same as {!List.assoc}, but uses physical equality instead of structural - equality to compare keys. *) + equality to compare keys. *) val mem_assoc : 'a -> ('a * 'b) list -> bool (** Same as {!List.assoc}, but simply return true if a binding exists, - and false if no bindings exist for the given key. *) + and false if no bindings exist for the given key. *) val mem_assq : 'a -> ('a * 'b) list -> bool (** Same as {!List.mem_assoc}, but uses physical equality instead of - structural equality to compare keys. *) + structural equality to compare keys. *) val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list (** [remove_assoc a l] returns the list of - pairs [l] without the first pair with key [a], if any. - Not tail-recursive. *) + pairs [l] without the first pair with key [a], if any. + Not tail-recursive. *) val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list (** Same as {!List.remove_assoc}, but uses physical equality instead - of structural equality to compare keys. Not tail-recursive. *) + of structural equality to compare keys. Not tail-recursive. *) (** {6 Lists of pairs} *) @@ -239,16 +239,16 @@ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list val split : ('a * 'b) list -> 'a list * 'b list (** Transform a list of pairs into a pair of lists: - [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. - Not tail-recursive. + [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. + Not tail-recursive. *) val combine : 'a list -> 'b list -> ('a * 'b) list (** Transform a pair of lists into a list of pairs: - [combine [a1; ...; an] [b1; ...; bn]] is - [[(a1,b1); ...; (an,bn)]]. - Raise [Invalid_argument] if the two lists - have different lengths. Not tail-recursive. *) + [combine [a1; ...; an] [b1; ...; bn]] is + [[(a1,b1); ...; (an,bn)]]. + Raise [Invalid_argument] if the two lists + have different lengths. Not tail-recursive. *) (** {6 Sorting} *) @@ -256,27 +256,27 @@ val combine : 'a list -> 'b list -> ('a * 'b) list val sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Sort a list in increasing order according to a comparison - function. The comparison function must return 0 if its arguments - compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller (see Array.sort for - a complete specification). For example, - {!Pervasives.compare} is a suitable comparison function. - The resulting list is sorted in increasing order. - [List.sort] is guaranteed to run in constant heap space - (in addition to the size of the result list) and logarithmic - stack space. + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see Array.sort for + a complete specification). For example, + {!Pervasives.compare} is a suitable comparison function. + The resulting list is sorted in increasing order. + [List.sort] is guaranteed to run in constant heap space + (in addition to the size of the result list) and logarithmic + stack space. - The current implementation uses Merge Sort. It runs in constant - heap space and logarithmic stack space. + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. *) val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!List.sort}, but the sorting algorithm is guaranteed to - be stable (i.e. elements that compare equal are kept in their - original order) . + be stable (i.e. elements that compare equal are kept in their + original order) . - The current implementation uses Merge Sort. It runs in constant - heap space and logarithmic stack space. + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. *) val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list diff --git a/src/environment/v1/lwt.mli b/src/environment/v1/lwt.mli index b6d3e7e52..97fafb14c 100644 --- a/src/environment/v1/lwt.mli +++ b/src/environment/v1/lwt.mli @@ -20,7 +20,7 @@ * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. - *) +*) (* TEZOS CHANGES @@ -62,63 +62,63 @@ (** {2 Definitions and basics} *) type +'a t - (** The type of threads returning a result of type ['a]. *) +(** The type of threads returning a result of type ['a]. *) val return : 'a -> 'a t - (** [return e] is a thread whose return value is the value of the - expression [e]. *) +(** [return e] is a thread whose return value is the value of the + expression [e]. *) (* val fail : exn -> 'a t *) (* (\** [fail e] is a thread that fails with the exception [e]. *\) *) val bind : 'a t -> ('a -> 'b t) -> 'b t - (** [bind t f] is a thread which first waits for the thread [t] to - terminate and then, if the thread succeeds, behaves as the - application of function [f] to the return value of [t]. If the - thread [t] fails, [bind t f] also fails, with the same - exception. +(** [bind t f] is a thread which first waits for the thread [t] to + terminate and then, if the thread succeeds, behaves as the + application of function [f] to the return value of [t]. If the + thread [t] fails, [bind t f] also fails, with the same + exception. - The expression [bind t (fun x -> t')] can intuitively be read as - [let x = t in t'], and if you use the {e lwt.syntax} syntax - extension, you can write a bind operation like that: [lwt x = t in t']. + The expression [bind t (fun x -> t')] can intuitively be read as + [let x = t in t'], and if you use the {e lwt.syntax} syntax + extension, you can write a bind operation like that: [lwt x = t in t']. - Note that [bind] is also often used just for synchronization - purpose: [t'] will not execute before [t] is terminated. + Note that [bind] is also often used just for synchronization + purpose: [t'] will not execute before [t] is terminated. - The result of a thread can be bound several time. *) + The result of a thread can be bound several time. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** [t >>= f] is an alternative notation for [bind t f]. *) +(** [t >>= f] is an alternative notation for [bind t f]. *) val (=<<) : ('a -> 'b t) -> 'a t -> 'b t - (** [f =<< t] is [t >>= f] *) +(** [f =<< t] is [t >>= f] *) val map : ('a -> 'b) -> 'a t -> 'b t - (** [map f m] map the result of a thread. This is the same as [bind - m (fun x -> return (f x))] *) +(** [map f m] map the result of a thread. This is the same as [bind + m (fun x -> return (f x))] *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** [m >|= f] is [map f m] *) +(** [m >|= f] is [map f m] *) val (=|<) : ('a -> 'b) -> 'a t -> 'b t - (** [f =|< m] is [map f m] *) +(** [f =|< m] is [map f m] *) (** {3 Pre-allocated threads} *) val return_unit : unit t - (** [return_unit = return ()] *) +(** [return_unit = return ()] *) val return_none : 'a option t - (** [return_none = return None] *) +(** [return_none = return None] *) val return_nil : 'a list t - (** [return_nil = return \[\]] *) +(** [return_nil = return \[\]] *) val return_true : bool t - (** [return_true = return true] *) +(** [return_true = return true] *) val return_false : bool t - (** [return_false = return false] *) +(** [return_false = return false] *) (* (\** {2 Thread storage} *\) *) @@ -223,18 +223,18 @@ val return_false : bool t (* the list of threads that have not yet terminated. *\) *) val join : unit t list -> unit t - (** [join l] waits for all threads in [l] to terminate. If one of - the threads fails, then [join l] will fails with the same - exception as the first one to terminate. +(** [join l] waits for all threads in [l] to terminate. If one of + the threads fails, then [join l] will fails with the same + exception as the first one to terminate. - Note: {!join} leaves the local values of the current thread - unchanged. *) + Note: {!join} leaves the local values of the current thread + unchanged. *) (* val ( ) : 'a t -> 'a t -> 'a t *) (* (\** [t t'] is the same as [choose [t; t']] *\) *) val ( <&> ) : unit t -> unit t -> unit t - (** [t <&> t'] is the same as [join [t; t']] *) +(** [t <&> t'] is the same as [join [t; t']] *) (* val async : (unit -> 'a t) -> unit *) (* (\** [async f] starts a thread without waiting for the result. If it *) diff --git a/src/environment/v1/lwt_list.mli b/src/environment/v1/lwt_list.mli index 44497cee8..93878b27b 100644 --- a/src/environment/v1/lwt_list.mli +++ b/src/environment/v1/lwt_list.mli @@ -18,7 +18,7 @@ * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. - *) +*) (** List helpers *) diff --git a/src/environment/v1/lwt_sequence.mli b/src/environment/v1/lwt_sequence.mli index 13c3d0f9f..214be9dc3 100644 --- a/src/environment/v1/lwt_sequence.mli +++ b/src/environment/v1/lwt_sequence.mli @@ -18,7 +18,7 @@ * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. - *) +*) (** Mutable sequence of elements *) @@ -32,124 +32,124 @@ *) type 'a t - (** Type of a sequence holding values of type ['a] *) +(** Type of a sequence holding values of type ['a] *) type 'a node - (** Type of a node holding one value of type ['a] in a sequence *) +(** Type of a node holding one value of type ['a] in a sequence *) (** {2 Operation on nodes} *) val get : 'a node -> 'a - (** Returns the contents of a node *) +(** Returns the contents of a node *) val set : 'a node -> 'a -> unit - (** Change the contents of a node *) +(** Change the contents of a node *) val remove : 'a node -> unit - (** Removes a node from the sequence it is part of. It does nothing - if the node has already been removed. *) +(** Removes a node from the sequence it is part of. It does nothing + if the node has already been removed. *) (** {2 Operations on sequence} *) val create : unit -> 'a t - (** [create ()] creates a new empty sequence *) +(** [create ()] creates a new empty sequence *) val is_empty : 'a t -> bool - (** Returns [true] iff the given sequence is empty *) +(** Returns [true] iff the given sequence is empty *) val length : 'a t -> int - (** Returns the number of elemenets in the given sequence. This is a - O(n) operation where [n] is the number of elements in the - sequence. *) +(** Returns the number of elemenets in the given sequence. This is a + O(n) operation where [n] is the number of elements in the + sequence. *) val add_l : 'a -> 'a t -> 'a node - (** [add_l x s] adds [x] to the left of the sequence [s] *) +(** [add_l x s] adds [x] to the left of the sequence [s] *) val add_r : 'a -> 'a t -> 'a node - (** [add_l x s] adds [x] to the right of the sequence [s] *) +(** [add_l x s] adds [x] to the right of the sequence [s] *) exception Empty - (** Exception raised by [take_l] and [tale_s] and when the sequence - is empty *) +(** Exception raised by [take_l] and [tale_s] and when the sequence + is empty *) val take_l : 'a t -> 'a - (** [take_l x s] remove and returns the leftmost element of [s] +(** [take_l x s] remove and returns the leftmost element of [s] - @raise Empty if the sequence is empty *) + @raise Empty if the sequence is empty *) val take_r : 'a t -> 'a - (** [take_l x s] remove and returns the rightmost element of [s] +(** [take_l x s] remove and returns the rightmost element of [s] - @raise Empty if the sequence is empty *) + @raise Empty if the sequence is empty *) val take_opt_l : 'a t -> 'a option - (** [take_opt_l x s] remove and returns [Some x] where [x] is the - leftmost element of [s] or [None] if [s] is empty *) +(** [take_opt_l x s] remove and returns [Some x] where [x] is the + leftmost element of [s] or [None] if [s] is empty *) val take_opt_r : 'a t -> 'a option - (** [take_opt_l x s] remove and returns [Some x] where [x] is the - rightmost element of [s] or [None] if [s] is empty *) +(** [take_opt_l x s] remove and returns [Some x] where [x] is the + rightmost element of [s] or [None] if [s] is empty *) val transfer_l : 'a t -> 'a t -> unit - (** [transfer_l s1 s2] removes all elements of [s1] and add them at - the left of [s2]. This operation runs in constant time and - space. *) +(** [transfer_l s1 s2] removes all elements of [s1] and add them at + the left of [s2]. This operation runs in constant time and + space. *) val transfer_r : 'a t -> 'a t -> unit - (** [transfer_r s1 s2] removes all elements of [s1] and add them at - the right of [s2]. This operation runs in constant time and - space. *) +(** [transfer_r s1 s2] removes all elements of [s1] and add them at + the right of [s2]. This operation runs in constant time and + space. *) (** {2 Sequence iterators} *) (** Note: it is OK to remove a node while traversing a sequence *) val iter_l : ('a -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all elements of [s] starting from - the left *) +(** [iter_l f s] applies [f] on all elements of [s] starting from + the left *) val iter_r : ('a -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all elements of [s] starting from - the right *) +(** [iter_l f s] applies [f] on all elements of [s] starting from + the right *) val iter_node_l : ('a node -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all nodes of [s] starting from - the left *) +(** [iter_l f s] applies [f] on all nodes of [s] starting from + the left *) val iter_node_r : ('a node -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all nodes of [s] starting from - the right *) +(** [iter_l f s] applies [f] on all nodes of [s] starting from + the right *) val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold_l f s] is: - {[ - fold_l f s x = f en (... (f e2 (f e1 x))) - ]} - where [e1], [e2], ..., [en] are the elements of [s] - *) +(** [fold_l f s] is: + {[ + fold_l f s x = f en (... (f e2 (f e1 x))) + ]} + where [e1], [e2], ..., [en] are the elements of [s] +*) val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold_r f s] is: - {[ - fold_r f s x = f e1 (f e2 (... (f en x))) - ]} - where [e1], [e2], ..., [en] are the elements of [s] - *) +(** [fold_r f s] is: + {[ + fold_r f s x = f e1 (f e2 (... (f en x))) + ]} + where [e1], [e2], ..., [en] are the elements of [s] +*) val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option - (** [find_node_opt_l f s] returns [Some x], where [x] is the first node of - [s] starting from the left that satisfies [f] or [None] if none - exists. *) +(** [find_node_opt_l f s] returns [Some x], where [x] is the first node of + [s] starting from the left that satisfies [f] or [None] if none + exists. *) val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option - (** [find_node_opt_r f s] returns [Some x], where [x] is the first node of - [s] starting from the right that satisfies [f] or [None] if none - exists. *) +(** [find_node_opt_r f s] returns [Some x], where [x] is the first node of + [s] starting from the right that satisfies [f] or [None] if none + exists. *) val find_node_l : ('a -> bool) -> 'a t -> 'a node - (** [find_node_l f s] returns the first node of [s] starting from the left - that satisfies [f] or raises [Not_found] if none exists. *) +(** [find_node_l f s] returns the first node of [s] starting from the left + that satisfies [f] or raises [Not_found] if none exists. *) val find_node_r : ('a -> bool) -> 'a t -> 'a node - (** [find_node_r f s] returns the first node of [s] starting from the right - that satisfies [f] or raises [Not_found] if none exists. *) +(** [find_node_r f s] returns the first node of [s] starting from the right + that satisfies [f] or raises [Not_found] if none exists. *) diff --git a/src/environment/v1/map.mli b/src/environment/v1/map.mli index d8c68f8fd..842c049bc 100644 --- a/src/environment/v1/map.mli +++ b/src/environment/v1/map.mli @@ -15,218 +15,218 @@ (** Association tables over ordered types. - This module implements applicative association tables, also known as - finite maps or dictionaries, given a total ordering function - over the keys. - All operations over maps are purely applicative (no side-effects). - The implementation uses balanced binary trees, and therefore searching - and insertion take time logarithmic in the size of the map. + This module implements applicative association tables, also known as + finite maps or dictionaries, given a total ordering function + over the keys. + All operations over maps are purely applicative (no side-effects). + The implementation uses balanced binary trees, and therefore searching + and insertion take time logarithmic in the size of the map. - For instance: - {[ - module IntPairs = - struct - type t = int * int - let compare (x0,y0) (x1,y1) = - match Pervasives.compare x0 x1 with - 0 -> Pervasives.compare y0 y1 - | c -> c - end + For instance: + {[ + module IntPairs = + struct + type t = int * int + let compare (x0,y0) (x1,y1) = + match Pervasives.compare x0 x1 with + 0 -> Pervasives.compare y0 y1 + | c -> c + end - module PairsMap = Map.Make(IntPairs) + module PairsMap = Map.Make(IntPairs) - let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world") - ]} + let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world") + ]} - This creates a new module [PairsMap], with a new type ['a PairsMap.t] - of maps from [int * int] to ['a]. In this example, [m] contains [string] - values so its type is [string PairsMap.t]. + This creates a new module [PairsMap], with a new type ['a PairsMap.t] + of maps from [int * int] to ['a]. In this example, [m] contains [string] + values so its type is [string PairsMap.t]. *) module type OrderedType = - sig - type t - (** The type of the map keys. *) +sig + type t + (** The type of the map keys. *) - val compare : t -> t -> int - (** A total ordering function over the keys. - This is a two-argument function [f] such that - [f e1 e2] is zero if the keys [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is the generic structural - comparison function {!Pervasives.compare}. *) - end + val compare : t -> t -> int + (** A total ordering function over the keys. + This is a two-argument function [f] such that + [f e1 e2] is zero if the keys [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) +end (** Input signature of the functor {!Map.Make}. *) module type S = - sig - type key - (** The type of the map keys. *) +sig + type key + (** The type of the map keys. *) - type (+'a) t - (** The type of maps from type [key] to type ['a]. *) + type (+'a) t + (** The type of maps from type [key] to type ['a]. *) - val empty: 'a t - (** The empty map. *) + val empty: 'a t + (** The empty map. *) - val is_empty: 'a t -> bool - (** Test whether a map is empty or not. *) + val is_empty: 'a t -> bool + (** Test whether a map is empty or not. *) - val mem: key -> 'a t -> bool - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) + val mem: key -> 'a t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) - val add: key -> 'a -> 'a t -> 'a t - (** [add x y m] returns a map containing the same bindings as - [m], plus a binding of [x] to [y]. If [x] was already bound - in [m] to a value that is physically equal to [y], - [m] is returned unchanged (the result of the function is - then physically equal to [m]). Otherwise, the previous binding - of [x] in [m] disappears. - @before 4.03 Physical equality was not ensured. *) + val add: key -> 'a -> 'a t -> 'a t + (** [add x y m] returns a map containing the same bindings as + [m], plus a binding of [x] to [y]. If [x] was already bound + in [m] to a value that is physically equal to [y], + [m] is returned unchanged (the result of the function is + then physically equal to [m]). Otherwise, the previous binding + of [x] in [m] disappears. + @before 4.03 Physical equality was not ensured. *) - val singleton: key -> 'a -> 'a t - (** [singleton x y] returns the one-element map that contains a binding [y] - for [x]. - @since 3.12.0 - *) + val singleton: key -> 'a -> 'a t + (** [singleton x y] returns the one-element map that contains a binding [y] + for [x]. + @since 3.12.0 + *) - val remove: key -> 'a t -> 'a t - (** [remove x m] returns a map containing the same bindings as - [m], except for [x] which is unbound in the returned map. - If [x] was not in [m], [m] is returned unchanged - (the result of the function is then physically equal to [m]). - @before 4.03 Physical equality was not ensured. *) + val remove: key -> 'a t -> 'a t + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. + If [x] was not in [m], [m] is returned unchanged + (the result of the function is then physically equal to [m]). + @before 4.03 Physical equality was not ensured. *) - val merge: - (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] - and of [m2]. The presence of each such binding, and the corresponding - value, is determined with the function [f]. - @since 3.12.0 - *) + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + @since 3.12.0 + *) - val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t - (** [union f m1 m2] computes a map whose keys is the union of keys - of [m1] and of [m2]. When the same binding is defined in both - arguments, the function [f] is used to combine them. - @since 4.03.0 - *) + val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + (** [union f m1 m2] computes a map whose keys is the union of keys + of [m1] and of [m2]. When the same binding is defined in both + arguments, the function [f] is used to combine them. + @since 4.03.0 + *) - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Total ordering between maps. The first argument is a total ordering - used to compare data associated with equal keys in the two maps. *) + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** Total ordering between maps. The first argument is a total ordering + used to compare data associated with equal keys in the two maps. *) - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are - equal, that is, contain equal keys and associate them with - equal data. [cmp] is the equality predicate used to compare - the data associated with the keys. *) + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) - val iter: (key -> 'a -> unit) -> 'a t -> unit - (** [iter f m] applies [f] to all bindings in map [m]. - [f] receives the key as first argument, and the associated value - as second argument. The bindings are passed to [f] in increasing - order with respect to the ordering over the type of the keys. *) + val iter: (key -> 'a -> unit) -> 'a t -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1 ... kN] are the keys of all bindings in [m] - (in increasing order), and [d1 ... dN] are the associated data. *) + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) - val for_all: (key -> 'a -> bool) -> 'a t -> bool - (** [for_all p m] checks if all the bindings of the map - satisfy the predicate [p]. - @since 3.12.0 - *) + val for_all: (key -> 'a -> bool) -> 'a t -> bool + (** [for_all p m] checks if all the bindings of the map + satisfy the predicate [p]. + @since 3.12.0 + *) - val exists: (key -> 'a -> bool) -> 'a t -> bool - (** [exists p m] checks if at least one binding of the map - satisfy the predicate [p]. - @since 3.12.0 - *) + val exists: (key -> 'a -> bool) -> 'a t -> bool + (** [exists p m] checks if at least one binding of the map + satisfy the predicate [p]. + @since 3.12.0 + *) - val filter: (key -> 'a -> bool) -> 'a t -> 'a t - (** [filter p m] returns the map with all the bindings in [m] - that satisfy predicate [p]. If [p] satisfies every binding in [m], - [m] is returned unchanged (the result of the function is then - physically equal to [m]) - @since 3.12.0 - @before 4.03 Physical equality was not ensured. - *) + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + (** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. If [p] satisfies every binding in [m], + [m] is returned unchanged (the result of the function is then + physically equal to [m]) + @since 3.12.0 + @before 4.03 Physical equality was not ensured. + *) - val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t - (** [partition p m] returns a pair of maps [(m1, m2)], where - [m1] contains all the bindings of [s] that satisfy the - predicate [p], and [m2] is the map with all the bindings of - [s] that do not satisfy [p]. - @since 3.12.0 - *) + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + (** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + @since 3.12.0 + *) - val cardinal: 'a t -> int - (** Return the number of bindings of a map. - @since 3.12.0 - *) + val cardinal: 'a t -> int + (** Return the number of bindings of a map. + @since 3.12.0 + *) - val bindings: 'a t -> (key * 'a) list - (** Return the list of all bindings of the given map. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Map.Make}. - @since 3.12.0 - *) + val bindings: 'a t -> (key * 'a) list + (** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + @since 3.12.0 + *) - val min_binding: 'a t -> (key * 'a) - (** Return the smallest binding of the given map - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the map is empty. - @since 3.12.0 - *) + val min_binding: 'a t -> (key * 'a) + (** Return the smallest binding of the given map + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the map is empty. + @since 3.12.0 + *) - val max_binding: 'a t -> (key * 'a) - (** Same as {!Map.S.min_binding}, but returns the largest binding - of the given map. - @since 3.12.0 - *) + val max_binding: 'a t -> (key * 'a) + (** Same as {!Map.S.min_binding}, but returns the largest binding + of the given map. + @since 3.12.0 + *) - val choose: 'a t -> (key * 'a) - (** Return one binding of the given map, or raise [Not_found] if - the map is empty. Which binding is chosen is unspecified, - but equal bindings will be chosen for equal maps. - @since 3.12.0 - *) + val choose: 'a t -> (key * 'a) + (** Return one binding of the given map, or raise [Not_found] if + the map is empty. Which binding is chosen is unspecified, + but equal bindings will be chosen for equal maps. + @since 3.12.0 + *) - val split: key -> 'a t -> 'a t * 'a option * 'a t - (** [split x m] returns a triple [(l, data, r)], where - [l] is the map with all the bindings of [m] whose key - is strictly less than [x]; - [r] is the map with all the bindings of [m] whose key - is strictly greater than [x]; - [data] is [None] if [m] contains no binding for [x], - or [Some v] if [m] binds [v] to [x]. - @since 3.12.0 - *) + val split: key -> 'a t -> 'a t * 'a option * 'a t + (** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + @since 3.12.0 + *) - val find: key -> 'a t -> 'a - (** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. *) + val find: key -> 'a t -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) - val map: ('a -> 'b) -> 'a t -> 'b t - (** [map f m] returns a map with same domain as [m], where the - associated value [a] of all bindings of [m] has been - replaced by the result of the application of [f] to [a]. - The bindings are passed to [f] in increasing order - with respect to the ordering over the type of the keys. *) + val map: ('a -> 'b) -> 'a t -> 'b t + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - (** Same as {!Map.S.map}, but the function receives as arguments both the - key and the associated value for each binding of the map. *) + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) - end +end (** Output signature of the functor {!Map.Make}. *) module Make (Ord : OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure - given a totally ordered type. *) + given a totally ordered type. *) diff --git a/src/environment/v1/persist.mli b/src/environment/v1/persist.mli index a03c922eb..908980af6 100644 --- a/src/environment/v1/persist.mli +++ b/src/environment/v1/persist.mli @@ -152,17 +152,17 @@ module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE) OCaml map as an explicitly synchronized in-memory buffer. *) module MakeBufferedPersistentMap (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := C.t - and module Map := Map + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := C.t + and module Map := Map (** {2 Predefined Instances} *************************************************) module MakePersistentBytesMap (S : STORE) (K : KEY) : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := MBytes.t + with type t := S.t and type key := K.t and type value := MBytes.t module MakeBufferedPersistentBytesMap (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) diff --git a/src/environment/v1/pervasives.mli b/src/environment/v1/pervasives.mli index 35e65e2f3..b61cd7dc1 100644 --- a/src/environment/v1/pervasives.mli +++ b/src/environment/v1/pervasives.mli @@ -26,13 +26,13 @@ (** The initially opened module. - This module provides the basic operations over the built-in types - (numbers, booleans, byte sequences, strings, exceptions, references, - lists, arrays, input-output channels, ...). + This module provides the basic operations over the built-in types + (numbers, booleans, byte sequences, strings, exceptions, references, + lists, arrays, input-output channels, ...). - This module is automatically opened at the beginning of each compilation. - All components of this module can therefore be referred by their short - name, without prefixing them by [Pervasives]. + This module is automatically opened at the beginning of each compilation. + All components of this module can therefore be referred by their short + name, without prefixing them by [Pervasives]. *) @@ -64,14 +64,14 @@ external not : bool -> bool = "%boolnot" external ( && ) : bool -> bool -> bool = "%sequand" (** The boolean 'and'. Evaluation is sequential, left-to-right: - in [e1 && e2], [e1] is evaluated first, and if it returns [false], - [e2] is not evaluated at all. *) + in [e1 && e2], [e1] is evaluated first, and if it returns [false], + [e2] is not evaluated at all. *) external ( || ) : bool -> bool -> bool = "%sequor" (** The boolean 'or'. Evaluation is sequential, left-to-right: - in [e1 || e2], [e1] is evaluated first, and if it returns [true], - [e2] is not evaluated at all. *) + in [e1 || e2], [e1] is evaluated first, and if it returns [true], + [e2] is not evaluated at all. *) (** {6 Debugging} *) @@ -107,7 +107,7 @@ external __POS__ : string * int * int * int = "%loc_POS" filename, [lnum] the line number, [cnum] the character position in the line and [enum] the last character position in the line. @since 4.02.0 - *) +*) external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" (** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the @@ -122,7 +122,7 @@ external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" line number at which the expression [expr] appears in the file currently being parsed by the compiler. @since 4.02.0 - *) +*) external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" (** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a @@ -132,27 +132,27 @@ external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" line number, [cnum] the character position in the line and [enum] the last character position in the line. @since 4.02.0 - *) +*) (** {6 Composition operators} *) external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" (** Reverse-application operator: [x |> f |> g] is exactly equivalent - to [g (f (x))]. - @since 4.01 + to [g (f (x))]. + @since 4.01 *) external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" (** Application operator: [g @@ f @@ x] is exactly equivalent to - [g (f (x))]. - @since 4.01 + [g (f (x))]. + @since 4.01 *) (** {6 Integer arithmetic} *) (** Integers are 31 bits wide (or 63 bits on 64-bit processors). - All operations are taken modulo 2{^31} (or 2{^63}). - They do not fail on overflow. *) + All operations are taken modulo 2{^31} (or 2{^63}). + They do not fail on overflow. *) external ( ~- ) : int -> int = "%negint" (** Unary negation. You can also write [- e] instead of [~- e]. *) @@ -179,24 +179,24 @@ external ( * ) : int -> int -> int = "%mulint" external ( / ) : int -> int -> int = "%divint" (** Integer division. - Raise [Division_by_zero] if the second argument is 0. - Integer division rounds the real quotient of its arguments towards zero. - More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer - less than or equal to the real quotient of [x] by [y]. Moreover, - [(- x) / y = x / (- y) = - (x / y)]. *) + Raise [Division_by_zero] if the second argument is 0. + Integer division rounds the real quotient of its arguments towards zero. + More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer + less than or equal to the real quotient of [x] by [y]. Moreover, + [(- x) / y = x / (- y) = - (x / y)]. *) external ( mod ) : int -> int -> int = "%modint" (** Integer remainder. If [y] is not zero, the result - of [x mod y] satisfies the following properties: - [x = (x / y) * y + x mod y] and - [abs(x mod y) <= abs(y) - 1]. - If [y = 0], [x mod y] raises [Division_by_zero]. - Note that [x mod y] is negative only if [x < 0]. - Raise [Division_by_zero] if [y] is zero. *) + of [x mod y] satisfies the following properties: + [x = (x / y) * y + x mod y] and + [abs(x mod y) <= abs(y) - 1]. + If [y = 0], [x mod y] raises [Division_by_zero]. + Note that [x mod y] is negative only if [x < 0]. + Raise [Division_by_zero] if [y] is zero. *) val abs : int -> int (** Return the absolute value of the argument. Note that this may be - negative if the argument is [min_int]. *) + negative if the argument is [min_int]. *) val max_int : int (** The greatest representable integer. *) @@ -221,34 +221,34 @@ val lnot : int -> int external ( lsl ) : int -> int -> int = "%lslint" (** [n lsl m] shifts [n] to the left by [m] bits. - The result is unspecified if [m < 0] or [m >= bitsize], - where [bitsize] is [32] on a 32-bit platform and - [64] on a 64-bit platform. *) + The result is unspecified if [m < 0] or [m >= bitsize], + where [bitsize] is [32] on a 32-bit platform and + [64] on a 64-bit platform. *) external ( lsr ) : int -> int -> int = "%lsrint" (** [n lsr m] shifts [n] to the right by [m] bits. - This is a logical shift: zeroes are inserted regardless of - the sign of [n]. - The result is unspecified if [m < 0] or [m >= bitsize]. *) + This is a logical shift: zeroes are inserted regardless of + the sign of [n]. + The result is unspecified if [m < 0] or [m >= bitsize]. *) external ( asr ) : int -> int -> int = "%asrint" (** [n asr m] shifts [n] to the right by [m] bits. - This is an arithmetic shift: the sign bit of [n] is replicated. - The result is unspecified if [m < 0] or [m >= bitsize]. *) + This is an arithmetic shift: the sign bit of [n] is replicated. + The result is unspecified if [m < 0] or [m >= bitsize]. *) (** {6 Floating-point arithmetic} - OCaml's floating-point numbers follow the - IEEE 754 standard, using double precision (64 bits) numbers. - Floating-point operations never raise an exception on overflow, - underflow, division by zero, etc. Instead, special IEEE numbers - are returned as appropriate, such as [infinity] for [1.0 /. 0.0], - [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') - for [0.0 /. 0.0]. These special numbers then propagate through - floating-point computations as expected: for instance, - [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] - as argument returns [nan] as result. + OCaml's floating-point numbers follow the + IEEE 754 standard, using double precision (64 bits) numbers. + Floating-point operations never raise an exception on overflow, + underflow, division by zero, etc. Instead, special IEEE numbers + are returned as appropriate, such as [infinity] for [1.0 /. 0.0], + [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') + for [0.0 /. 0.0]. These special numbers then propagate through + floating-point computations as expected: for instance, + [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] + as argument returns [nan] as result. *) external ( ~-. ) : float -> float = "%negfloat" @@ -272,13 +272,13 @@ external ( /. ) : float -> float -> float = "%divfloat" (** Floating-point division. *) external ceil : float -> float = "caml_ceil_float" "ceil" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Round above to an integer value. [ceil f] returns the least integer value greater than or equal to [f]. The result is returned as a float. *) external floor : float -> float = "caml_floor_float" "floor" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Round below to an integer value. [floor f] returns the greatest integer value less than or equal to [f]. @@ -288,26 +288,26 @@ external abs_float : float -> float = "%absfloat" (** [abs_float f] returns the absolute value of [f]. *) external copysign : float -> float -> float - = "caml_copysign_float" "caml_copysign" - [@@unboxed] [@@noalloc] + = "caml_copysign_float" "caml_copysign" +[@@unboxed] [@@noalloc] (** [copysign x y] returns a float whose absolute value is that of [x] - and whose sign is that of [y]. If [x] is [nan], returns [nan]. - If [y] is [nan], returns either [x] or [-. x], but it is not - specified which. - @since 4.00.0 *) + and whose sign is that of [y]. If [x] is [nan], returns [nan]. + If [y] is [nan], returns either [x] or [-. x], but it is not + specified which. + @since 4.00.0 *) external mod_float : float -> float -> float = "caml_fmod_float" "fmod" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** [mod_float a b] returns the remainder of [a] with respect to - [b]. The returned value is [a -. n *. b], where [n] - is the quotient [a /. b] rounded towards zero to an integer. *) + [b]. The returned value is [a -. n *. b], where [n] + is the quotient [a /. b] rounded towards zero to an integer. *) external frexp : float -> float * int = "caml_frexp_float" (** [frexp f] returns the pair of the significant - and the exponent of [f]. When [f] is zero, the - significant [x] and the exponent [n] of [f] are equal to - zero. When [f] is non-zero, they are defined by - [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) + and the exponent of [f]. When [f] is zero, the + significant [x] and the exponent [n] of [f] are equal to + zero. When [f] is non-zero, they are defined by + [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) = @@ -316,7 +316,7 @@ external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) = external modf : float -> float * float = "caml_modf_float" (** [modf f] returns the pair of the fractional and integral - part of [f]. *) + part of [f]. *) external float : int -> float = "%floatofint" (** Same as {!Pervasives.float_of_int}. *) @@ -329,8 +329,8 @@ external truncate : float -> int = "%intoffloat" external int_of_float : float -> int = "%intoffloat" (** Truncate the given floating-point number to an integer. - The result is unspecified if the argument is [nan] or falls outside the - range of representable integers. *) + The result is unspecified if the argument is [nan] or falls outside the + range of representable integers. *) val infinity : float (** Positive infinity. *) @@ -340,11 +340,11 @@ val neg_infinity : float val nan : float (** A special floating-point value denoting the result of an - undefined operation such as [0.0 /. 0.0]. Stands for - 'not a number'. Any floating-point operation with [nan] as - argument returns [nan] as result. As for floating-point comparisons, - [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] - if one or both of their arguments is [nan]. *) + undefined operation such as [0.0 /. 0.0]. Stands for + 'not a number'. Any floating-point operation with [nan] as + argument returns [nan] as result. As for floating-point comparisons, + [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] + if one or both of their arguments is [nan]. *) val max_float : float (** The largest positive finite value of type [float]. *) @@ -363,17 +363,17 @@ type fpclass = | FP_infinite (** Number is positive or negative infinity *) | FP_nan (** Not a number: result of an undefined operation *) (** The five classes of floating-point numbers, as determined by - the {!Pervasives.classify_float} function. *) + the {!Pervasives.classify_float} function. *) external classify_float : (float [@unboxed]) -> fpclass = "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc] (** Return the class of the given floating-point number: - normal, subnormal, zero, infinite, or not a number. *) + normal, subnormal, zero, infinite, or not a number. *) (** {6 String operations} - More string operations are provided in module {!String}. + More string operations are provided in module {!String}. *) val ( ^ ) : string -> string -> string @@ -382,7 +382,7 @@ val ( ^ ) : string -> string -> string (** {6 Character operations} - More character operations are provided in module {!Char}. + More character operations are provided in module {!Char}. *) external int_of_char : char -> int = "%identity" @@ -390,66 +390,66 @@ external int_of_char : char -> int = "%identity" val char_of_int : int -> char (** Return the character with the given ASCII code. - Raise [Invalid_argument "char_of_int"] if the argument is - outside the range 0--255. *) + Raise [Invalid_argument "char_of_int"] if the argument is + outside the range 0--255. *) (** {6 Unit operations} *) external ignore : 'a -> unit = "%ignore" (** Discard the value of its argument and return [()]. - For instance, [ignore(f x)] discards the result of - the side-effecting function [f]. It is equivalent to - [f x; ()], except that the latter may generate a - compiler warning; writing [ignore(f x)] instead - avoids the warning. *) + For instance, [ignore(f x)] discards the result of + the side-effecting function [f]. It is equivalent to + [f x; ()], except that the latter may generate a + compiler warning; writing [ignore(f x)] instead + avoids the warning. *) (** {6 String conversion functions} *) val string_of_bool : bool -> string (** Return the string representation of a boolean. As the returned values - may be shared, the user should not modify them directly. + may be shared, the user should not modify them directly. *) val bool_of_string : string -> bool (** Convert the given string to a boolean. - Raise [Invalid_argument "bool_of_string"] if the string is not - ["true"] or ["false"]. *) + Raise [Invalid_argument "bool_of_string"] if the string is not + ["true"] or ["false"]. *) val string_of_int : int -> string (** Return the string representation of an integer, in decimal. *) external int_of_string : string -> int = "caml_int_of_string" (** Convert the given string to an integer. - The string is read in decimal (by default), in hexadecimal (if it - begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), - or in binary (if it begins with [0b] or [0B]). - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Raise [Failure "int_of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [int]. *) + The string is read in decimal (by default), in hexadecimal (if it + begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), + or in binary (if it begins with [0b] or [0B]). + The [_] (underscore) character can appear anywhere in the string + and is ignored. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int]. *) val string_of_float : float -> string (** Return the string representation of a floating-point number. *) external float_of_string : string -> float = "caml_float_of_string" (** Convert the given string to a float. The string is read in decimal - (by default) or in hexadecimal (marked by [0x] or [0X]). - The format of decimal floating-point numbers is - [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. - The format of hexadecimal floating-point numbers is - [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an - hexadecimal digit and [d] for a decimal digit. - In both cases, at least one of the integer and fractional parts must be - given; the exponent part is optional. - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Depending on the execution platforms, other representations of - floating-point numbers can be accepted, but should not be relied upon. - Raise [Failure "float_of_string"] if the given string is not a valid - representation of a float. *) + (by default) or in hexadecimal (marked by [0x] or [0X]). + The format of decimal floating-point numbers is + [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. + The format of hexadecimal floating-point numbers is + [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an + hexadecimal digit and [d] for a decimal digit. + In both cases, at least one of the integer and fractional parts must be + given; the exponent part is optional. + The [_] (underscore) character can appear anywhere in the string + and is ignored. + Depending on the execution platforms, other representations of + floating-point numbers can be accepted, but should not be relied upon. + Raise [Failure "float_of_string"] if the given string is not a valid + representation of a float. *) (** {6 Pair operations} *) @@ -462,7 +462,7 @@ external snd : 'a * 'b -> 'b = "%field1" (** {6 List operations} - More list operations are provided in module {!List}. + More list operations are provided in module {!List}. *) val ( @ ) : 'a list -> 'a list -> 'a list @@ -473,26 +473,26 @@ val ( @ ) : 'a list -> 'a list -> 'a list type 'a ref = { mutable contents : 'a } (** The type of references (mutable indirection cells) containing - a value of type ['a]. *) + a value of type ['a]. *) external ref : 'a -> 'a ref = "%makemutable" (** Return a fresh reference containing the given value. *) external ( ! ) : 'a ref -> 'a = "%field0" (** [!r] returns the current contents of reference [r]. - Equivalent to [fun r -> r.contents]. *) + Equivalent to [fun r -> r.contents]. *) external ( := ) : 'a ref -> 'a -> unit = "%setfield0" (** [r := a] stores the value of [a] in reference [r]. - Equivalent to [fun r v -> r.contents <- v]. *) + Equivalent to [fun r v -> r.contents <- v]. *) external incr : int ref -> unit = "%incr" (** Increment the integer contained in the given reference. - Equivalent to [fun r -> r := succ !r]. *) + Equivalent to [fun r -> r := succ !r]. *) external decr : int ref -> unit = "%decr" (** Decrement the integer contained in the given reference. - Equivalent to [fun r -> r := pred !r]. *) + Equivalent to [fun r -> r := pred !r]. *) (** {6 Result type} *) @@ -501,30 +501,30 @@ type ('a,'b) result = Ok of 'a | Error of 'b (** {6 Operations on format strings} *) (** Format strings are character strings with special lexical conventions - that defines the functionality of formatted input/output functions. Format - strings are used to read data with formatted input functions from module - {!Scanf} and to print data with formatted output functions from modules - {!Printf} and {!Format}. + that defines the functionality of formatted input/output functions. Format + strings are used to read data with formatted input functions from module + {!Scanf} and to print data with formatted output functions from modules + {!Printf} and {!Format}. - Format strings are made of three kinds of entities: - - {e conversions specifications}, introduced by the special character ['%'] + Format strings are made of three kinds of entities: + - {e conversions specifications}, introduced by the special character ['%'] followed by one or more characters specifying what kind of argument to read or print, - - {e formatting indications}, introduced by the special character ['@'] + - {e formatting indications}, introduced by the special character ['@'] followed by one or more characters specifying how to read or print the argument, - - {e plain characters} that are regular characters with usual lexical + - {e plain characters} that are regular characters with usual lexical conventions. Plain characters specify string literals to be read in the input or printed in the output. - There is an additional lexical rule to escape the special characters ['%'] - and ['@'] in format strings: if a special character follows a ['%'] - character, it is treated as a plain character. In other words, ["%%"] is - considered as a plain ['%'] and ["%@"] as a plain ['@']. + There is an additional lexical rule to escape the special characters ['%'] + and ['@'] in format strings: if a special character follows a ['%'] + character, it is treated as a plain character. In other words, ["%%"] is + considered as a plain ['%'] and ["%@"] as a plain ['@']. - For more information about conversion specifications and formatting - indications available, read the documentation of modules {!Scanf}, - {!Printf} and {!Format}. + For more information about conversion specifications and formatting + indications available, read the documentation of modules {!Scanf}, + {!Printf} and {!Format}. *) (** Format strings have a general and highly polymorphic type @@ -593,9 +593,9 @@ val ( ^^ ) : ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6 (** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a - format string that behaves as the concatenation of format strings [f1] and - [f2]: in case of formatted output, it accepts arguments from [f1], then - arguments from [f2]; in case of formatted input, it returns results from - [f1], then results from [f2]. + format string that behaves as the concatenation of format strings [f1] and + [f2]: in case of formatted output, it accepts arguments from [f1], then + arguments from [f2]; in case of formatted input, it returns results from + [f1], then results from [f2]. *) diff --git a/src/environment/v1/set.mli b/src/environment/v1/set.mli index f57999eb1..a44c6ee95 100644 --- a/src/environment/v1/set.mli +++ b/src/environment/v1/set.mli @@ -15,191 +15,191 @@ (** Sets over ordered types. - This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses balanced binary trees, and is therefore - reasonably efficient: insertion and membership take time - logarithmic in the size of the set, for instance. + This module implements the set data structure, given a total ordering + function over the set elements. All operations over sets + are purely applicative (no side-effects). + The implementation uses balanced binary trees, and is therefore + reasonably efficient: insertion and membership take time + logarithmic in the size of the set, for instance. - The [Make] functor constructs implementations for any type, given a - [compare] function. - For instance: - {[ - module IntPairs = - struct - type t = int * int - let compare (x0,y0) (x1,y1) = - match Pervasives.compare x0 x1 with - 0 -> Pervasives.compare y0 y1 - | c -> c - end + The [Make] functor constructs implementations for any type, given a + [compare] function. + For instance: + {[ + module IntPairs = + struct + type t = int * int + let compare (x0,y0) (x1,y1) = + match Pervasives.compare x0 x1 with + 0 -> Pervasives.compare y0 y1 + | c -> c + end - module PairsSet = Set.Make(IntPairs) + module PairsSet = Set.Make(IntPairs) - let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13)) - ]} + let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13)) + ]} - This creates a new module [PairsSet], with a new type [PairsSet.t] - of sets of [int * int]. + This creates a new module [PairsSet], with a new type [PairsSet.t] + of sets of [int * int]. *) module type OrderedType = - sig - type t - (** The type of the set elements. *) +sig + type t + (** The type of the set elements. *) - val compare : t -> t -> int - (** A total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is the generic structural - comparison function {!Pervasives.compare}. *) - end + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that + [f e1 e2] is zero if the elements [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) +end (** Input signature of the functor {!Set.Make}. *) module type S = - sig - type elt - (** The type of the set elements. *) +sig + type elt + (** The type of the set elements. *) - type t - (** The type of sets. *) + type t + (** The type of sets. *) - val empty: t - (** The empty set. *) + val empty: t + (** The empty set. *) - val is_empty: t -> bool - (** Test whether a set is empty or not. *) + val is_empty: t -> bool + (** Test whether a set is empty or not. *) - val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) + val mem: elt -> t -> bool + (** [mem x s] tests whether [x] belongs to the set [s]. *) - val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged - (the result of the function is then physically equal to [s]). - @before 4.03 Physical equality was not ensured. *) + val add: elt -> t -> t + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged + (the result of the function is then physically equal to [s]). + @before 4.03 Physical equality was not ensured. *) - val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) + val singleton: elt -> t + (** [singleton x] returns the one-element set containing only [x]. *) - val remove: elt -> t -> t - (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged - (the result of the function is then physically equal to [s]). - @before 4.03 Physical equality was not ensured. *) + val remove: elt -> t -> t + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged + (the result of the function is then physically equal to [s]). + @before 4.03 Physical equality was not ensured. *) - val union: t -> t -> t - (** Set union. *) + val union: t -> t -> t + (** Set union. *) - val inter: t -> t -> t - (** Set intersection. *) + val inter: t -> t -> t + (** Set intersection. *) - val diff: t -> t -> t - (** Set difference. *) + val diff: t -> t -> t + (** Set difference. *) - val compare: t -> t -> int - (** Total ordering between sets. Can be used as the ordering function - for doing sets of sets. *) + val compare: t -> t -> int + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) - val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) + val equal: t -> t -> bool + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) - val subset: t -> t -> bool - (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) + val subset: t -> t -> bool + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) - val iter: (elt -> unit) -> t -> unit - (** [iter f s] applies [f] in turn to all elements of [s]. - The elements of [s] are presented to [f] in increasing order - with respect to the ordering over the type of the elements. *) + val iter: (elt -> unit) -> t -> unit + (** [iter f s] applies [f] in turn to all elements of [s]. + The elements of [s] are presented to [f] in increasing order + with respect to the ordering over the type of the elements. *) - val map: (elt -> elt) -> t -> t - (** [map f s] is the set whose elements are [f a0],[f a1]... [f - aN], where [a0],[a1]...[aN] are the elements of [s]. + val map: (elt -> elt) -> t -> t + (** [map f s] is the set whose elements are [f a0],[f a1]... [f + aN], where [a0],[a1]...[aN] are the elements of [s]. - The elements are passed to [f] in increasing order - with respect to the ordering over the type of the elements. + The elements are passed to [f] in increasing order + with respect to the ordering over the type of the elements. - If no element of [s] is changed by [f], [s] is returned - unchanged. (If each output of [f] is physically equal to its - input, the returned set is physically equal to [s].) *) + If no element of [s] is changed by [f], [s] is returned + unchanged. (If each output of [f] is physically equal to its + input, the returned set is physically equal to [s].) *) - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s], in increasing order. *) + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) - val for_all: (elt -> bool) -> t -> bool - (** [for_all p s] checks if all elements of the set - satisfy the predicate [p]. *) + val for_all: (elt -> bool) -> t -> bool + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) - val exists: (elt -> bool) -> t -> bool - (** [exists p s] checks if at least one element of - the set satisfies the predicate [p]. *) + val exists: (elt -> bool) -> t -> bool + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) - val filter: (elt -> bool) -> t -> t - (** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. If [p] satisfies every element in [s], - [s] is returned unchanged (the result of the function is then - physically equal to [s]). - @before 4.03 Physical equality was not ensured.*) + val filter: (elt -> bool) -> t -> t + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. If [p] satisfies every element in [s], + [s] is returned unchanged (the result of the function is then + physically equal to [s]). + @before 4.03 Physical equality was not ensured.*) - val partition: (elt -> bool) -> t -> t * t - (** [partition p s] returns a pair of sets [(s1, s2)], where - [s1] is the set of all the elements of [s] that satisfy the - predicate [p], and [s2] is the set of all the elements of - [s] that do not satisfy [p]. *) + val partition: (elt -> bool) -> t -> t * t + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) - val cardinal: t -> int - (** Return the number of elements of a set. *) + val cardinal: t -> int + (** Return the number of elements of a set. *) - val elements: t -> elt list - (** Return the list of all elements of the given set. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Set.Make}. *) + val elements: t -> elt list + (** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Set.Make}. *) - val min_elt: t -> elt - (** Return the smallest element of the given set - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the set is empty. *) + val min_elt: t -> elt + (** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) - val max_elt: t -> elt - (** Same as {!Set.S.min_elt}, but returns the largest element of the - given set. *) + val max_elt: t -> elt + (** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) - val choose: t -> elt - (** Return one element of the given set, or raise [Not_found] if - the set is empty. Which element is chosen is unspecified, - but equal elements will be chosen for equal sets. *) + val choose: t -> elt + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) - val split: elt -> t -> t * bool * t - (** [split x s] returns a triple [(l, present, r)], where - [l] is the set of elements of [s] that are - strictly less than [x]; - [r] is the set of elements of [s] that are - strictly greater than [x]; - [present] is [false] if [s] contains no element equal to [x], - or [true] if [s] contains an element equal to [x]. *) + val split: elt -> t -> t * bool * t + (** [split x s] returns a triple [(l, present, r)], where + [l] is the set of elements of [s] that are + strictly less than [x]; + [r] is the set of elements of [s] that are + strictly greater than [x]; + [present] is [false] if [s] contains no element equal to [x], + or [true] if [s] contains an element equal to [x]. *) - val find: elt -> t -> elt - (** [find x s] returns the element of [s] equal to [x] (according - to [Ord.compare]), or raise [Not_found] if no such element - exists. - @since 4.01.0 *) + val find: elt -> t -> elt + (** [find x s] returns the element of [s] equal to [x] (according + to [Ord.compare]), or raise [Not_found] if no such element + exists. + @since 4.01.0 *) - val of_list: elt list -> t - (** [of_list l] creates a set from a list of elements. - This is usually more efficient than folding [add] over the list, - except perhaps for lists with many duplicated elements. - @since 4.02.0 *) - end + val of_list: elt list -> t + (** [of_list l] creates a set from a list of elements. + This is usually more efficient than folding [add] over the list, + except perhaps for lists with many duplicated elements. + @since 4.02.0 *) +end (** Output signature of the functor {!Set.Make}. *) module Make (Ord : OrderedType) : S with type elt = Ord.t (** Functor building an implementation of the set structure - given a totally ordered type. *) + given a totally ordered type. *) diff --git a/src/environment/v1/string.mli b/src/environment/v1/string.mli index 73ff181f4..b2ac035ab 100644 --- a/src/environment/v1/string.mli +++ b/src/environment/v1/string.mli @@ -24,40 +24,40 @@ (** String operations. - A string is an immutable data structure that contains a - fixed-length sequence of (single-byte) characters. Each character - can be accessed in constant time through its index. + A string is an immutable data structure that contains a + fixed-length sequence of (single-byte) characters. Each character + can be accessed in constant time through its index. - Given a string [s] of length [l], we can access each of the [l] - characters of [s] via its index in the sequence. Indexes start at - [0], and we will call an index valid in [s] if it falls within the - range [[0...l-1]] (inclusive). A position is the point between two - characters or at the beginning or end of the string. We call a - position valid in [s] if it falls within the range [[0...l]] - (inclusive). Note that the character at index [n] is between - positions [n] and [n+1]. + Given a string [s] of length [l], we can access each of the [l] + characters of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + characters or at the beginning or end of the string. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the character at index [n] is between + positions [n] and [n+1]. - Two parameters [start] and [len] are said to designate a valid - substring of [s] if [len >= 0] and [start] and [start+len] are - valid positions in [s]. + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. - *) +*) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns the character at index [n] in string [s]. - You can also write [s.[n]] instead of [String.get s n]. + You can also write [s.[n]] instead of [String.get s n]. - Raise [Invalid_argument] if [n] not a valid index in [s]. *) + Raise [Invalid_argument] if [n] not a valid index in [s]. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], - filled with the character [c]. + filled with the character [c]. - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val init : int -> (int -> char) -> string (** [String.init n f] returns a string of length [n], with character @@ -71,11 +71,11 @@ val init : int -> (int -> char) -> string val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], - containing the substring of [s] that starts at position [start] and - has length [len]. + containing the substring of [s] that starts at position [start] and + has length [len]. - Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]. *) + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) val blit : string -> int -> bytes -> int -> int -> unit (** Same as {!Bytes.blit_string}. *) @@ -89,14 +89,14 @@ val concat : string -> string list -> string val iter : (char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all - the characters of [s]. It is equivalent to - [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) + the characters of [s]. It is equivalent to + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) val iteri : (int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the - function is applied to the index of the element as first argument - (counting from 0), and the character itself as second argument. - @since 4.00.0 *) + function is applied to the index of the element as first argument + (counting from 0), and the character itself as second argument. + @since 4.00.0 *) val map : (char -> char) -> string -> string (** [String.map f s] applies function [f] in turn to all the @@ -112,11 +112,11 @@ val mapi : (int -> char -> char) -> string -> string val trim : string -> string (** Return a copy of the argument, without leading and trailing - whitespace. The characters regarded as whitespace are: [' '], - ['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor - trailing whitespace character in the argument, return the original - string itself, not a copy. - @since 4.00.0 *) + whitespace. The characters regarded as whitespace are: [' '], + ['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor + trailing whitespace character in the argument, return the original + string itself, not a copy. + @since 4.00.0 *) val escaped : string -> string (** Return a copy of the argument, with special characters @@ -137,71 +137,71 @@ val escaped : string -> string val index : string -> char -> int (** [String.index s c] returns the index of the first - occurrence of character [c] in string [s]. + occurrence of character [c] in string [s]. - Raise [Not_found] if [c] does not occur in [s]. *) + Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int (** [String.rindex s c] returns the index of the last - occurrence of character [c] in string [s]. + occurrence of character [c] in string [s]. - Raise [Not_found] if [c] does not occur in [s]. *) + Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int (** [String.index_from s i c] returns the index of the - first occurrence of character [c] in string [s] after position [i]. - [String.index s c] is equivalent to [String.index_from s 0 c]. + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. - Raise [Invalid_argument] if [i] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] after position [i]. *) + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int (** [String.rindex_from s i c] returns the index of the - last occurrence of character [c] in string [s] before position [i+1]. - [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. + last occurrence of character [c] in string [s] before position [i+1]. + [String.rindex s c] is equivalent to + [String.rindex_from s (String.length s - 1) c]. - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] - appears in the string [s]. *) + appears in the string [s]. *) val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] - appears in [s] after position [start]. - [String.contains s c] is equivalent to - [String.contains_from s 0 c]. + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. - Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] - appears in [s] before position [stop+1]. + appears in [s] before position [stop+1]. - Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid - position in [s]. *) + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) val uppercase_ascii : string -> string (** Return a copy of the argument, with all lowercase letters - translated to uppercase, using the US-ASCII character set. - @since 4.03.0 *) + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) val lowercase_ascii : string -> string (** Return a copy of the argument, with all uppercase letters - translated to lowercase, using the US-ASCII character set. - @since 4.03.0 *) + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) val capitalize_ascii : string -> string (** Return a copy of the argument, with the first character set to uppercase, - using the US-ASCII character set. - @since 4.03.0 *) + using the US-ASCII character set. + @since 4.03.0 *) val uncapitalize_ascii : string -> string (** Return a copy of the argument, with the first character set to lowercase, - using the US-ASCII character set. - @since 4.03.0 *) + using the US-ASCII character set. + @since 4.03.0 *) type t = string (** An alias for the type of strings. *) diff --git a/src/environment/v1/z.mli b/src/environment/v1/z.mli index 000eb61a7..271e6d16d 100644 --- a/src/environment/v1/z.mli +++ b/src/environment/v1/z.mli @@ -30,7 +30,7 @@ val ediv_rem: t -> t -> (t * t) (** Euclidean division and remainder. [ediv_rem a b] returns a pair [(q, r)] such that [a = b * q + r] and [0 <= r < |b|]. Raises [Division_by_zero] if [b = 0]. - *) +*) external logand: t -> t -> t = "ml_z_logand" "ml_as_z_logand" (** Bitwise logical and. *) @@ -44,20 +44,20 @@ external logxor: t -> t -> t = "ml_z_logxor" "ml_as_z_logxor" external lognot: t -> t = "ml_z_lognot" "ml_as_z_lognot" (** Bitwise logical negation. The identity [lognot a]=[-a-1] always hold. - *) +*) external shift_left: t -> int -> t = "ml_z_shift_left" "ml_as_z_shift_left" (** Shifts to the left. Equivalent to a multiplication by a power of 2. The second argument must be non-negative. - *) +*) external shift_right: t -> int -> t = "ml_z_shift_right" "ml_as_z_shift_right" (** Shifts to the right. This is an arithmetic shift, equivalent to a division by a power of 2 with rounding towards -oo. The second argument must be non-negative. - *) +*) val to_string: t -> string val of_string: string -> t diff --git a/src/micheline/micheline.ml b/src/micheline/micheline.ml index 75edc50e8..8dd83c2c8 100644 --- a/src/micheline/micheline.ml +++ b/src/micheline/micheline.ml @@ -31,16 +31,16 @@ let canonical_location_encoding = int31 let location = function - | Int (loc, _) -> loc - | String (loc, _) -> loc - | Seq (loc, _, _) -> loc - | Prim (loc, _, _, _) -> loc + | Int (loc, _) -> loc + | String (loc, _) -> loc + | Seq (loc, _, _) -> loc + | Prim (loc, _, _, _) -> loc let annotation = function - | Int (_, _) -> None - | String (_, _) -> None - | Seq (_, _, annot) -> annot - | Prim (_, _, _, annot) -> annot + | Int (_, _) -> None + | String (_, _) -> None + | Seq (_, _, annot) -> annot + | Prim (_, _, _, annot) -> annot let root (Canonical expr) = expr @@ -100,18 +100,18 @@ let map f (Canonical expr) = | Seq (loc, seq, annot) -> Seq (loc, List.map (map_node f) seq, annot) | Prim (loc, name, seq, annot) -> - Prim (loc, f name, List.map (map_node f) seq, annot) in + Prim (loc, f name, List.map (map_node f) seq, annot) in Canonical (map_node f expr) let rec map_node fl fp = function | Int (loc, v) -> - Int (fl loc, v) + Int (fl loc, v) | String (loc, v) -> - String (fl loc, v) + String (fl loc, v) | Seq (loc, seq, annot) -> - Seq (fl loc, List.map (map_node fl fp) seq, annot) + Seq (fl loc, List.map (map_node fl fp) seq, annot) | Prim (loc, name, seq, annot) -> - Prim (fl loc, fp name, List.map (map_node fl fp) seq, annot) + Prim (fl loc, fp name, List.map (map_node fl fp) seq, annot) let canonical_encoding prim_encoding = let open Data_encoding in diff --git a/src/minutils/RPC.ml b/src/minutils/RPC.ml index 95b0ec917..811cbda73 100644 --- a/src/minutils/RPC.ml +++ b/src/minutils/RPC.ml @@ -51,11 +51,11 @@ let string_of_method = function let service ?(meth = default_meth) ?description ~input ~output path = (meth, - Resto.service - ?description - ~input:(Data_encoding.Json.convert input) - ~output:(Data_encoding.Json.convert output) - path) + Resto.service + ?description + ~input:(Data_encoding.Json.convert input) + ~output:(Data_encoding.Json.convert output) + path) (* REST services *) diff --git a/src/minutils/RPC.mli b/src/minutils/RPC.mli index 2a7344311..8bab98b98 100644 --- a/src/minutils/RPC.mli +++ b/src/minutils/RPC.mli @@ -289,10 +289,10 @@ val register_dynamic_directory3: (** Registring custom directory lookup. *) type custom_lookup = RestoDirectory.custom_lookup - (* | CustomService of Description.service_descr * *) - (* ( Data_encoding.json option -> *) - (* Data_encoding.json Answer.answer Lwt.t ) *) - (* | CustomDirectory of Description.directory_descr *) +(* | CustomService of Description.service_descr * *) +(* ( Data_encoding.json option -> *) +(* Data_encoding.json Answer.answer Lwt.t ) *) +(* | CustomDirectory of Description.directory_descr *) val register_custom_lookup: ?meth:meth -> diff --git a/src/minutils/compare.ml b/src/minutils/compare.ml index fd96fe1e4..816f512fd 100644 --- a/src/minutils/compare.ml +++ b/src/minutils/compare.ml @@ -89,19 +89,19 @@ module MakeUnsigned(Int : S)(Z : sig val zero : Int.t end) = struct type t = Int.t let compare va vb = Int.(if va >= Z.zero then if vb >= Z.zero then compare va vb else -1 - else if vb >= Z.zero then 1 else compare va vb) + else if vb >= Z.zero then 1 else compare va vb) let (=) = ((=) : t -> t -> bool) let (<>) = ((<>) : t -> t -> bool) let (<) a b = Int.(if Z.zero <= a then - (a < b || b < Z.zero) - else - (b < Z.zero && a < b)) + (a < b || b < Z.zero) + else + (b < Z.zero && a < b)) let (<=) a b = Int.(if Z.zero <= a then - (a <= b || b < Z.zero) - else - (b < Z.zero && a <= b)) + (a <= b || b < Z.zero) + else + (b < Z.zero && a <= b)) let (>=) a b = (<=) b a let (>) a b = (<) b a let max x y = if x >= y then x else y diff --git a/src/minutils/data_encoding.ml b/src/minutils/data_encoding.ml index 99ca34746..8d193f200 100644 --- a/src/minutils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -285,34 +285,34 @@ module Json = struct and lift_union_in_pair : 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) } -> - make @@ - Union (`Dynamic (* ignored *), tag, - List.map - (fun (Case { encoding = e2 ; proj ; inj ; tag }) -> - Case { encoding = lift_union_in_pair b p e1 e2 ; - proj = (fun (x, y) -> - match proj y with - | None -> None - | Some y -> Some (x, y)) ; - inj = (fun (x, y) -> (x, inj y)) ; - tag }) - cases) - | { encoding = Union (_kind, tag, cases) }, e2 -> - make @@ - Union (`Dynamic (* ignored *), tag, - List.map - (fun (Case { encoding = e1 ; proj ; inj ; tag }) -> - Case { encoding = lift_union_in_pair b p e1 e2 ; - proj = (fun (x, y) -> - match proj x with - | None -> None - | Some x -> Some (x, y)) ; - inj = (fun (x, y) -> (inj x, y)) ; - tag }) - cases) - | e1, e2 -> b.build p e1 e2 + match lift_union e1, lift_union e2 with + | e1, { encoding = Union (_kind, tag, cases) } -> + make @@ + Union (`Dynamic (* ignored *), tag, + List.map + (fun (Case { encoding = e2 ; proj ; inj ; tag }) -> + Case { encoding = lift_union_in_pair b p e1 e2 ; + proj = (fun (x, y) -> + match proj y with + | None -> None + | Some y -> Some (x, y)) ; + inj = (fun (x, y) -> (x, inj y)) ; + tag }) + cases) + | { encoding = Union (_kind, tag, cases) }, e2 -> + make @@ + Union (`Dynamic (* ignored *), tag, + List.map + (fun (Case { encoding = e1 ; proj ; inj ; tag }) -> + Case { encoding = lift_union_in_pair b p e1 e2 ; + proj = (fun (x, y) -> + match proj x with + | None -> None + | Some x -> Some (x, y)) ; + inj = (fun (x, y) -> (inj x, y)) ; + tag }) + cases) + | e1, e2 -> b.build p e1 e2 let rec json : type a. a desc -> a Json_encoding.encoding = let open Json_encoding in @@ -384,7 +384,7 @@ module Json = struct | `Star (** Any / every field or index. *) | `Next - (** The next element after an array. *) ] + (** The next element after an array. *) ] include Json_encoding @@ -632,7 +632,7 @@ module Encoding = struct (((h, g), (f, e)), ((d, c), (b, a)))) (fun (((h, g), (f, e)), ((d, c), (b, a))) -> (h, g, f, e, d, c, b, a)) - ty + ty let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1) let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1) let conv9 ty = @@ -735,7 +735,7 @@ module Binary = struct read: 'a. 'a t -> MBytes.t -> int -> int -> (int * 'a) ; } -let rec length : type x. x t -> x -> int = fun e -> + let rec length : type x. x t -> x -> int = fun e -> match e.encoding with (* Fixed *) | Null -> fun _ -> 0 @@ -1265,7 +1265,7 @@ let rec length : type x. x t -> x -> int = fun e -> | P_seq : { path : path ; encoding : 'a t ; fun_data_len : int -> int } -> path | P_list : { path:path ; encoding:'a t ; data_len : int ; - base_ofs : int ; nb_elts_read : int } -> path + base_ofs : int ; nb_elts_read : int } -> path (* used to accumulate given mbytes when reading a list of blocks, as well as the current offset and the number of unread bytes *) @@ -1634,18 +1634,18 @@ let rec length : type x. x t -> x -> int = fun e -> MBytes.t list -> 'a t -> (MBytes.t Queue.t -> int -> 'b option) -> 'b status = fun l e success_result -> - match classify e with - | `Variable -> invalid_arg "streaming data with variable size" - | `Fixed _ | `Dynamic -> - let mb_buf = { - past = Queue.create() ; past_len = 0 ; - future = Queue.create() ; unread = 0; ofs = 0 } - in - List.iter (insert_mbytes mb_buf) l ; - let path = - P_await { path = P_top ; encoding = e ; data_len = - 1 } in - try bytes_stream_reader_rec (data_checker path mb_buf) success_result - with _ -> Error + match classify e with + | `Variable -> invalid_arg "streaming data with variable size" + | `Fixed _ | `Dynamic -> + let mb_buf = { + past = Queue.create() ; past_len = 0 ; + future = Queue.create() ; unread = 0; ofs = 0 } + in + List.iter (insert_mbytes mb_buf) l ; + let path = + P_await { path = P_top ; encoding = e ; data_len = - 1 } in + try bytes_stream_reader_rec (data_checker path mb_buf) success_result + with _ -> Error end diff --git a/src/minutils/data_encoding.mli b/src/minutils/data_encoding.mli index 6d06d228b..3e655965a 100644 --- a/src/minutils/data_encoding.mli +++ b/src/minutils/data_encoding.mli @@ -81,11 +81,11 @@ val unit : unit encoding val constant : string -> unit encoding (** Signed 8 bit integer - (data is encoded as a byte in binary and an integer in JSON). *) + (data is encoded as a byte in binary and an integer in JSON). *) val int8 : int encoding (** Unsigned 8 bit integer - (data is encoded as a byte in binary and an integer in JSON). *) + (data is encoded as a byte in binary and an integer in JSON). *) val uint8 : int encoding (** Signed 16 bit integer @@ -93,7 +93,7 @@ val uint8 : int encoding val int16 : int encoding (** Unsigned 16 bit integer - (data is encoded as a short in binary and an integer in JSON). *) + (data is encoded as a short in binary and an integer in JSON). *) val uint16 : int encoding (** Signed 31 bit integer, which corresponds to type int on 32-bit OCaml systems @@ -105,7 +105,7 @@ val int31 : int encoding val int32 : int32 encoding (** Signed 64 bit integer - (data is encodedas a 64-bit int in binary and a decimal string in JSON). *) + (data is encodedas a 64-bit int in binary and a decimal string in JSON). *) val int64 : int64 encoding (** Encoding of a boolean diff --git a/src/minutils/utils.ml b/src/minutils/utils.ml index bd3e9836f..3fdf311a7 100644 --- a/src/minutils/utils.ml +++ b/src/minutils/utils.ml @@ -111,12 +111,12 @@ let merge_filter_list2 | r1, [] -> finalize acc @ (filter_map (fun x1 -> f (Some x1) None) r1) | [], r2 -> finalize acc @ (filter_map (fun x2 -> f None (Some x2)) r2) | ((h1 :: t1) as r1), ((h2 :: t2) as r2) -> - if compare h1 h2 > 0 then - merge_aux (may_cons acc (f None (Some h2))) (r1, t2) - else if compare h1 h2 < 0 then - merge_aux (may_cons acc (f (Some h1) None)) (t1, r2) - else (* m1 = m2 *) - merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2) + if compare h1 h2 > 0 then + merge_aux (may_cons acc (f None (Some h2))) (r1, t2) + else if compare h1 h2 < 0 then + merge_aux (may_cons acc (f (Some h1) None)) (t1, r2) + else (* m1 = m2 *) + merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2) in merge_aux [] (sort l1, sort l2) @@ -149,9 +149,9 @@ let rec remove_elem_from_list nb = function let split_list_at n l = let rec split n acc = function - | [] -> List.rev acc, [] - | l when n <= 0 -> List.rev acc, l - | hd :: tl -> split (n - 1) (hd :: acc) tl in + | [] -> List.rev acc, [] + | l when n <= 0 -> List.rev acc, l + | hd :: tl -> split (n - 1) (hd :: acc) tl in split n [] l let has_prefix ~prefix s = diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 732936a71..fc64e1aa4 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -131,7 +131,7 @@ let commit ~time ~message context = code dt end end >>= fun () -> - Lwt.return commit + Lwt.return commit (*-- Generic Store Primitives ------------------------------------------------*) diff --git a/src/node/db/persist.mli b/src/node/db/persist.mli index 67b54e107..ded7b96a4 100644 --- a/src/node/db/persist.mli +++ b/src/node/db/persist.mli @@ -162,18 +162,18 @@ module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE) OCaml map as an explicitly synchronized in-memory buffer. *) module MakeBufferedPersistentMap (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := C.t - and module Map := Map + : BUFFERED_PERSISTENT_MAP + with type t := S.t + and type key := K.t + and type value := C.t + and module Map := Map (** {2 Predefined Instances} *************************************************) module MakePersistentBytesMap (S : STORE) (K : KEY) : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := MBytes.t + with type t := S.t and type key := K.t and type value := MBytes.t module MakeBufferedPersistentBytesMap (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 2c0a2766b..6e4413eb8 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -97,9 +97,9 @@ module Block = struct let open Data_encoding in conv (fun { header ; message ; max_operations_ttl ; context } -> - (message, max_operations_ttl, context, header)) + (message, max_operations_ttl, context, header)) (fun (message, max_operations_ttl, context, header) -> - { header ; message ; max_operations_ttl ; context }) + { header ; message ; max_operations_ttl ; context }) (obj4 (req "message" string) (req "max_operations_ttl" uint16) diff --git a/src/node/db/store_helpers.ml b/src/node/db/store_helpers.ml index 978044abe..b450618ee 100644 --- a/src/node/db/store_helpers.ml +++ b/src/node/db/store_helpers.ml @@ -113,9 +113,9 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct | Some path -> f path acc else S.fold t path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> dig (i-1) k acc - | `Key _ -> Lwt.return acc + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc end in dig I.path_length [] init diff --git a/src/node/db/store_helpers.mli b/src/node/db/store_helpers.mli index 2c465fa36..54dcab813 100644 --- a/src/node/db/store_helpers.mli +++ b/src/node/db/store_helpers.mli @@ -26,8 +26,8 @@ module Make_set (S : STORE) (I : INDEX) module Make_buffered_set (S : STORE) (I : INDEX) (Set : Set.S with type elt = I.t) : BUFFERED_SET_STORE with type t = S.t - and type elt = I.t - and module Set = Set + and type elt = I.t + and module Set = Set module Make_map (S : STORE) (I : INDEX) (V : VALUE) diff --git a/src/node/main/node_data_version.ml b/src/node/main/node_data_version.ml index af58a460e..c54696ce8 100644 --- a/src/node/main/node_data_version.ml +++ b/src/node/main/node_data_version.ml @@ -30,8 +30,8 @@ let () = ~title: "Invalid data directory version" ~description: "The data directory version was not the one that was expected" Data_encoding.(obj2 - (req "expectedVersion" string) - (req "actualVersion" string)) + (req "expectedVersion" string) + (req "actualVersion" string)) (function | Invalid_data_dir_version (expected, actual) -> Some (expected, actual) @@ -59,7 +59,7 @@ let () = ~pp:(fun ppf path -> Format.fprintf ppf "Expected to find data directory version file at '%s', \ - \ but the file did not exist." + \ but the file did not exist." path) (function No_data_dir_version_file path -> Some path | _ -> None) (fun path -> No_data_dir_version_file path) diff --git a/src/node/main/node_run_command.ml b/src/node/main/node_run_command.ml index 6a3a40ec1..d275806da 100644 --- a/src/node/main/node_run_command.ml +++ b/src/node/main/node_run_command.ml @@ -115,25 +115,25 @@ let init_node ?sandbox (config : Node_config_file.t) = | _ -> (Node_config_file.resolve_bootstrap_addrs config.net.bootstrap_peers) >>= fun trusted_points -> - Node_identity_file.read - (config.data_dir // - Node_identity_file.default_name) >>=? fun identity -> - lwt_log_notice - "Peer's global id: %a" - P2p.Peer_id.pp identity.peer_id >>= fun () -> - let p2p_config : P2p.config = - { listening_addr ; - listening_port ; - trusted_points ; - peers_file = - (config.data_dir // "peers.json") ; - closed_network = config.net.closed ; - identity ; - proof_of_work_target = - Crypto_box.make_target config.net.expected_pow ; - } - in - return (Some (p2p_config, config.net.limits)) + Node_identity_file.read + (config.data_dir // + Node_identity_file.default_name) >>=? fun identity -> + lwt_log_notice + "Peer's global id: %a" + P2p.Peer_id.pp identity.peer_id >>= fun () -> + let p2p_config : P2p.config = + { listening_addr ; + listening_port ; + trusted_points ; + peers_file = + (config.data_dir // "peers.json") ; + closed_network = config.net.closed ; + identity ; + proof_of_work_target = + Crypto_box.make_target config.net.expected_pow ; + } + in + return (Some (p2p_config, config.net.limits)) end >>=? fun p2p_config -> let node_config : Node.config = { genesis ; diff --git a/src/node/main/node_shared_arg.ml b/src/node/main/node_shared_arg.ml index a7e2216bf..27b006edd 100644 --- a/src/node/main/node_shared_arg.ml +++ b/src/node/main/node_shared_arg.ml @@ -155,7 +155,7 @@ module Term = struct let binary_chunks_size = let doc = Format.sprintf - "Size limit (in kB) of binary blocks that are sent to other peers." + "Size limit (in kB) of binary blocks that are sent to other peers." in Arg.(value & opt (some int) None & info ~docs ~doc ~docv:"NUM" ["binary-chunks-size"]) diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 95a34bef3..78b9396dd 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -226,10 +226,10 @@ module Real = struct P2p_connection_pool.Connection.fold net.pool ~init:[] ~f:begin fun _peer_id conn acc -> - (P2p_connection_pool.is_readable conn >>= function - | Ok () -> Lwt.return (Some conn) - | Error _ -> Lwt_utils.never_ending) :: acc - end in + (P2p_connection_pool.is_readable conn >>= function + | Ok () -> Lwt.return (Some conn) + | Error _ -> Lwt_utils.never_ending) :: acc + end in Lwt.pick ( ( P2p_connection_pool.Pool_event.wait_new_connection net.pool >>= fun () -> Lwt.return_none ):: diff --git a/src/node/net/p2p_connection_pool.ml b/src/node/net/p2p_connection_pool.ml index b3fcdbb1e..9a4b96e22 100644 --- a/src/node/net/p2p_connection_pool.ml +++ b/src/node/net/p2p_connection_pool.ml @@ -460,8 +460,8 @@ module GcPeer_idSet = Utils.Bounded(struct end) let gc_peer_ids ({ meta_config = { score } ; - config = { max_known_peer_ids } ; - known_peer_ids ; } as pool) = + config = { max_known_peer_ids } ; + known_peer_ids ; } as pool) = match max_known_peer_ids with | None -> () | Some (_, target) -> @@ -804,13 +804,13 @@ and authenticate pool ?point_info canceler fd point = unopt_map connection_point_info ~default:(not pool.config.closed_network) ~f:begin fun connection_point_info -> - match Point_info.State.get connection_point_info with - | Requested _ -> not incoming - | Disconnected -> - not pool.config.closed_network - || Point_info.trusted connection_point_info - | Accepted _ | Running _ -> false - end + match Point_info.State.get connection_point_info with + | Requested _ -> not incoming + | Disconnected -> + not pool.config.closed_network + || Point_info.trusted connection_point_info + | Accepted _ | Running _ -> false + end in let acceptable_peer_id = match Peer_info.State.get peer_info with @@ -975,7 +975,7 @@ and swap_request pool conn new_point _new_peer_id = (Time.max pool.latest_succesfull_swap pool.latest_accepted_swap) in let new_point_info = register_point pool source_peer_id new_point in if span_since_last_swap < int_of_float pool.config.swap_linger - || not (Point_info.State.is_disconnected new_point_info) then begin + || not (Point_info.State.is_disconnected new_point_info) then begin log pool (Swap_request_ignored { source = source_peer_id }) ; lwt_log_info "Ignoring swap request from %a" Peer_id.pp source_peer_id end else begin @@ -1043,7 +1043,7 @@ let accept pool fd point = log pool (Incoming_connection point) ; if pool.config.max_incoming_connections <= Point.Table.length pool.incoming || pool.config.max_connections <= active_connections pool then - Lwt.async (fun () -> Lwt_utils.safe_close fd) + Lwt.async (fun () -> Lwt_utils.safe_close fd) else let canceler = Canceler.create () in Point.Table.add pool.incoming point canceler ; diff --git a/src/node/net/p2p_connection_pool_types.ml b/src/node/net/p2p_connection_pool_types.ml index 48df90174..11a9426db 100644 --- a/src/node/net/p2p_connection_pool_types.ml +++ b/src/node/net/p2p_connection_pool_types.ml @@ -367,26 +367,26 @@ module Peer_info = struct let open Data_encoding in conv (fun { peer_id ; trusted ; metadata ; events ; created ; - last_failed_connection ; last_rejected_connection ; - last_established_connection ; last_disconnection } -> - (peer_id, created, trusted, metadata, Ring.elements events, - last_failed_connection, last_rejected_connection, - last_established_connection, last_disconnection)) + last_failed_connection ; last_rejected_connection ; + last_established_connection ; last_disconnection } -> + (peer_id, created, trusted, metadata, Ring.elements events, + last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection)) (fun (peer_id, created, trusted, metadata, event_list, - last_failed_connection, last_rejected_connection, - last_established_connection, last_disconnection) -> - let info = create ~trusted ~metadata peer_id in - let events = Ring.create log_size in - Ring.add_list info.events event_list ; - { state = Disconnected ; - trusted ; peer_id ; metadata ; created ; - last_failed_connection ; - last_rejected_connection ; - last_established_connection ; - last_disconnection ; - events ; - watchers = Watcher.create_input () ; - }) + last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection) -> + let info = create ~trusted ~metadata peer_id in + let events = Ring.create log_size in + Ring.add_list info.events event_list ; + { state = Disconnected ; + trusted ; peer_id ; metadata ; created ; + last_failed_connection ; + last_rejected_connection ; + last_established_connection ; + last_disconnection ; + events ; + watchers = Watcher.create_input () ; + }) (obj9 (req "peer_id" Peer_id.encoding) (req "created" Time.encoding) diff --git a/src/node/net/p2p_connection_pool_types.mli b/src/node/net/p2p_connection_pool_types.mli index 4740678d5..b491f7804 100644 --- a/src/node/net/p2p_connection_pool_types.mli +++ b/src/node/net/p2p_connection_pool_types.mli @@ -76,15 +76,15 @@ module Point_info : sig type 'conn t = | Requested of { cancel: Canceler.t } - (** We initiated a connection. *) + (** We initiated a connection. *) | Accepted of { current_peer_id: Peer_id.t ; cancel: Canceler.t } - (** We accepted a incoming connection. *) + (** We accepted a incoming connection. *) | Running of { data: 'conn ; current_peer_id: Peer_id.t } - (** Successfully authentificated connection, normal business. *) + (** Successfully authentificated connection, normal business. *) | Disconnected - (** No connection established currently. *) + (** No connection established currently. *) type 'conn state = 'conn t val pp : Format.formatter -> 'conn t -> unit @@ -113,19 +113,19 @@ module Point_info : sig type kind = | Outgoing_request - (** We initiated a connection. *) + (** We initiated a connection. *) | Accepting_request of Peer_id.t - (** We accepted a connection after authentifying the remote peer. *) + (** We accepted a connection after authentifying the remote peer. *) | Rejecting_request of Peer_id.t - (** We rejected a connection after authentifying the remote peer. *) + (** We rejected a connection after authentifying the remote peer. *) | Request_rejected of Peer_id.t option - (** The remote peer rejected our connection. *) + (** The remote peer rejected our connection. *) | Connection_established of Peer_id.t - (** We succesfully established a authentified connection. *) + (** We succesfully established a authentified connection. *) | Disconnection of Peer_id.t - (** We decided to close the connection. *) + (** We decided to close the connection. *) | External_disconnection of Peer_id.t - (** The connection was closed for external reason. *) + (** The connection was closed for external reason. *) type t = { kind : kind ; @@ -207,13 +207,13 @@ module Peer_info : sig type 'conn t = | Accepted of { current_point: Id_point.t ; cancel: Canceler.t } - (** We accepted a incoming connection, we greeted back and - we are waiting for an acknowledgement. *) + (** We accepted a incoming connection, we greeted back and + we are waiting for an acknowledgement. *) | Running of { data: 'conn ; current_point: Id_point.t } - (** Successfully authentificated connection, normal business. *) + (** Successfully authentificated connection, normal business. *) | Disconnected - (** No connection established currently. *) + (** No connection established currently. *) type 'conn state = 'conn t val pp : Format.formatter -> 'conn t -> unit @@ -241,17 +241,17 @@ module Peer_info : sig type kind = | Accepting_request - (** We accepted a connection after authentifying the remote peer. *) + (** We accepted a connection after authentifying the remote peer. *) | Rejecting_request - (** We rejected a connection after authentifying the remote peer. *) + (** We rejected a connection after authentifying the remote peer. *) | Request_rejected - (** The remote peer rejected our connection. *) + (** The remote peer rejected our connection. *) | Connection_established - (** We succesfully established a authentified connection. *) + (** We succesfully established a authentified connection. *) | Disconnection - (** We decided to close the connection. *) + (** We decided to close the connection. *) | External_disconnection - (** The connection was closed for external reason. *) + (** The connection was closed for external reason. *) type t = { kind : kind ; diff --git a/src/node/net/p2p_io_scheduler.ml b/src/node/net/p2p_io_scheduler.ml index bd27d6f8e..1c82bdd96 100644 --- a/src/node/net/p2p_io_scheduler.ml +++ b/src/node/net/p2p_io_scheduler.ml @@ -206,7 +206,7 @@ module Scheduler(IO : IO) = struct st.readys_low ; Queue.clear st.readys_low ; Queue.transfer tmp st.readys_low ; - end + end let shutdown st = lwt_debug "--> scheduler(%s).shutdown" IO.name >>= fun () -> @@ -349,42 +349,42 @@ let write_size mbytes = let register = let cpt = ref 0 in fun st conn -> - if st.closed then begin - Lwt.async (fun () -> Lwt_utils.safe_close conn) ; - raise Closed - end else begin - let id = incr cpt; !cpt in - let canceler = Canceler.create () in - let read_size = - map_option st.read_queue_size ~f:(fun v -> v, read_size) in - let write_size = - map_option st.write_queue_size ~f:(fun v -> v, write_size) in - let read_queue = Lwt_pipe.create ?size:read_size () in - let write_queue = Lwt_pipe.create ?size:write_size () in - let read_conn = - ReadScheduler.create_connection - st.read_scheduler (conn, st.read_buffer_size) read_queue canceler id - and write_conn = - WriteScheduler.create_connection - st.write_scheduler write_queue conn canceler id in - Canceler.on_cancel canceler begin fun () -> - Inttbl.remove st.connected id ; - Moving_average.destroy read_conn.counter ; - Moving_average.destroy write_conn.counter ; - Lwt_pipe.close write_queue ; - Lwt_pipe.close read_queue ; - Lwt_utils.safe_close conn - end ; - let conn = { - sched = st ; id ; conn ; canceler ; - read_queue ; read_conn ; - write_queue ; write_conn ; - partial_read = None ; - } in - Inttbl.add st.connected id conn ; - log_info "--> register (%d)" conn.id ; - conn - end + if st.closed then begin + Lwt.async (fun () -> Lwt_utils.safe_close conn) ; + raise Closed + end else begin + let id = incr cpt; !cpt in + let canceler = Canceler.create () in + let read_size = + map_option st.read_queue_size ~f:(fun v -> v, read_size) in + let write_size = + map_option st.write_queue_size ~f:(fun v -> v, write_size) in + let read_queue = Lwt_pipe.create ?size:read_size () in + let write_queue = Lwt_pipe.create ?size:write_size () in + let read_conn = + ReadScheduler.create_connection + st.read_scheduler (conn, st.read_buffer_size) read_queue canceler id + and write_conn = + WriteScheduler.create_connection + st.write_scheduler write_queue conn canceler id in + Canceler.on_cancel canceler begin fun () -> + Inttbl.remove st.connected id ; + Moving_average.destroy read_conn.counter ; + Moving_average.destroy write_conn.counter ; + Lwt_pipe.close write_queue ; + Lwt_pipe.close read_queue ; + Lwt_utils.safe_close conn + end ; + let conn = { + sched = st ; id ; conn ; canceler ; + read_queue ; read_conn ; + write_queue ; write_conn ; + partial_read = None ; + } in + Inttbl.add st.connected id conn ; + log_info "--> register (%d)" conn.id ; + conn + end let write { write_queue } msg = Lwt.catch diff --git a/src/node/net/p2p_maintenance.ml b/src/node/net/p2p_maintenance.ml index 65d3b1665..b9db43e91 100644 --- a/src/node/net/p2p_maintenance.ml +++ b/src/node/net/p2p_maintenance.ml @@ -160,7 +160,7 @@ let rec worker_loop st = end >>=? fun () -> let n_connected = P2p_connection_pool.active_connections pool in if n_connected < st.bounds.min_threshold - || st.bounds.max_threshold < n_connected then + || st.bounds.max_threshold < n_connected then maintain st else begin P2p_connection_pool.send_swap_request pool ; diff --git a/src/node/net/p2p_types.mli b/src/node/net/p2p_types.mli index aab206b0e..6cb6f39df 100644 --- a/src/node/net/p2p_types.mli +++ b/src/node/net/p2p_types.mli @@ -95,8 +95,8 @@ module Identity : sig val generate_with_animation : Format.formatter -> Crypto_box.target -> t - (** [generate_with_animation ppf target] is a freshly minted identity - whose proof of work stamp difficulty is at least equal to [target]. *) + (** [generate_with_animation ppf target] is a freshly minted identity + whose proof of work stamp difficulty is at least equal to [target]. *) end diff --git a/src/node/shell/block_locator.ml b/src/node/shell/block_locator.ml index 65b0647e5..705e91112 100644 --- a/src/node/shell/block_locator.ml +++ b/src/node/shell/block_locator.ml @@ -31,10 +31,10 @@ let compute (b: Block.t) sz = | Some predecessor -> if cpt = 0 then loop (Block.hash b :: acc) (sz - 1) - (step * 2) (step * 20 - 1) predecessor + (step * 2) (step * 20 - 1) predecessor else if cpt mod step = 0 then loop (Block.hash b :: acc) (sz - 1) - step (cpt - 1) predecessor + step (cpt - 1) predecessor else loop acc sz step (cpt - 1) predecessor in Block.predecessor b >>= function @@ -78,8 +78,8 @@ type step = { let to_steps locator = fold ~f:begin fun acc ~block ~pred ~step ~strict_step -> { - block ; predecessor = pred ; step ; strict_step ; - } :: acc + block ; predecessor = pred ; step ; strict_step ; + } :: acc end [] locator diff --git a/src/node/shell/chain_traversal.mli b/src/node/shell/chain_traversal.mli index e15b12ce9..9256136e3 100644 --- a/src/node/shell/chain_traversal.mli +++ b/src/node/shell/chain_traversal.mli @@ -49,4 +49,4 @@ val live_blocks: [blocks] is the set of arity [n], that contains [b] and its [n-1] predecessors. And where [operations] is the set of operations included in those blocks. - *) +*) diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index c04f95cb2..497f94ca4 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -25,7 +25,7 @@ module Make_raw val name : string val encoding : t Data_encoding.t val pp : Format.formatter -> t -> unit - end) + end) (Disk_table : Distributed_db_functors.DISK_TABLE with type key := Hash.t) (Memory_table : @@ -329,10 +329,10 @@ and p2p_reader = { } let noop_callback = { - notify_branch = begin fun _gid _locator -> () end ; - notify_head = begin fun _gid _block _ops -> () end ; - disconnection = begin fun _gid -> () end ; - } + notify_branch = begin fun _gid _locator -> () end ; + notify_head = begin fun _gid _block _ops -> () end ; + disconnection = begin fun _gid -> () end ; +} type t = db @@ -566,7 +566,7 @@ module P2p_reader = struct | None -> Lwt.return_unit | Some bh -> if Operation_list_list_hash.compare - found_hash bh.shell.operations_hash <> 0 then + found_hash bh.shell.operations_hash <> 0 then Lwt.return_unit else Raw_operations.Table.notify @@ -671,9 +671,9 @@ let activate ({ p2p ; active_nets } as global_db) net_state = active_connections = P2p.Peer_id.Table.create 53 ; } in P2p.iter_connections p2p (fun _peer_id conn -> - Lwt.async begin fun () -> - P2p.send p2p conn (Get_current_branch net_id) - end) ; + Lwt.async begin fun () -> + P2p.send p2p conn (Get_current_branch net_id) + end) ; Net_id.Table.add active_nets net_id net ; net | net -> @@ -695,7 +695,7 @@ let deactivate net_db = net_db.active_connections ; Raw_operation.shutdown net_db.operation_db >>= fun () -> Raw_block_header.shutdown net_db.block_header_db >>= fun () -> - Lwt.return_unit >>= fun () -> + Lwt.return_unit >>= fun () -> Lwt.return_unit let get_net { active_nets } net_id = @@ -715,9 +715,9 @@ let shutdown { p2p ; p2p_readers ; active_nets } = Lwt.return_unit >>= fun () -> Net_id.Table.fold (fun _ net_db acc -> - Raw_operation.shutdown net_db.operation_db >>= fun () -> - Raw_block_header.shutdown net_db.block_header_db >>= fun () -> - acc) + Raw_operation.shutdown net_db.operation_db >>= fun () -> + Raw_block_header.shutdown net_db.block_header_db >>= fun () -> + acc) active_nets Lwt.return_unit >>= fun () -> P2p.shutdown p2p >>= fun () -> diff --git a/src/node/shell/distributed_db_functors.ml b/src/node/shell/distributed_db_functors.ml index 6a00203e0..2a728d59a 100644 --- a/src/node/shell/distributed_db_functors.ml +++ b/src/node/shell/distributed_db_functors.ml @@ -259,7 +259,7 @@ end = struct ~f:(fun input -> Watcher.notify input (k, v)) ; Watcher.notify s.input (k, v) ; Lwt.return_unit - end + end | Found _ -> Scheduler.notify_duplicate s.scheduler p k ; Lwt.return_unit diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 8d53855be..0b482972a 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -150,7 +150,7 @@ module RPC = struct operations: Operation_hash.t list list option ; protocol: Protocol_hash.t ; test_network: Context.test_network; - } + } let convert (block: State.Block.t) = let hash = State.Block.hash block in @@ -363,7 +363,7 @@ module RPC = struct operations = begin fun () -> Lwt_list.map_p (Lwt_list.map_p - (Distributed_db.Operation.read_exn net_db)) + (Distributed_db.Operation.read_exn net_db)) operation_hashes end ; context ; diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 5ee12d9cb..5db5b2991 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -26,17 +26,17 @@ let monitor_operations node contents = | None -> Lwt.return_none | Some (h, op) when contents -> Lwt.return (Some [[h, Some op]]) | Some (h, _) -> Lwt.return (Some [[h, None]]) - else begin - first_request := false ; - Node.RPC.operation_hashes node `Prevalidation >>= fun hashes -> - if contents then - Node.RPC.operations node `Prevalidation >>= fun ops -> - Lwt.return_some @@ - List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops - else - Lwt.return_some @@ - List.map (List.map (fun h -> h, None)) hashes - end in + else begin + first_request := false ; + Node.RPC.operation_hashes node `Prevalidation >>= fun hashes -> + if contents then + Node.RPC.operations node `Prevalidation >>= fun ops -> + Lwt.return_some @@ + List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops + else + Lwt.return_some @@ + List.map (List.map (fun h -> h, None)) hashes + end in RPC.Answer.return_stream { next ; shutdown } let register_bi_dir node dir = @@ -178,7 +178,7 @@ let create_delayed_stream future_blocks := rest ; future_blocks_set := Block_hash.Set.remove bi.hash !future_blocks_set ; - Some bi + Some bi | _ -> None in next, mem, insert, pop in let _block_watcher_worker = @@ -275,7 +275,7 @@ let list_blocks | Some time -> let rec current_predecessor (bi: Node.RPC.block_info) = if Time.compare bi.timestamp time <= 0 - || bi.hash = bi.predecessor then + || bi.hash = bi.predecessor then Lwt.return bi else Node.RPC.raw_block_info node bi.predecessor >>= @@ -287,7 +287,7 @@ let list_blocks (fun (bi1: Services.Blocks.block_info) (bi2: Services.Blocks.block_info) -> - ~- (Fitness.compare bi1.fitness bi2.fitness)) + ~- (Fitness.compare bi1.fitness bi2.fitness)) heads_info in List.map (fun ({ hash } : Services.Blocks.block_info) -> hash) @@ -453,7 +453,7 @@ let build_rpc_directory node = let stream, stopper = Node.RPC.Network.watch node in let shutdown () = Watcher.shutdown stopper in let next () = Lwt_stream.get stream in - RPC.Answer.return_stream { next ; shutdown } in + RPC.Answer.return_stream { next ; shutdown } in RPC.register0 dir Services.Network.events implementation in let dir = let implementation point timeout = @@ -500,7 +500,7 @@ let build_rpc_directory node = end in RPC.Answer.return_stream { next ; shutdown } else - Node.RPC.Network.Peer_id.events node peer_id |> RPC.Answer.return in + Node.RPC.Network.Peer_id.events node peer_id |> RPC.Answer.return in RPC.register1 dir Services.Network.Peer_id.events implementation in (* Network : Point *) diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 34ca5e7c1..b698097f1 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -25,7 +25,7 @@ module Error = struct (Printf.sprintf "The full list of error is available with \ the global RPC `%s /%s`" - (RPC.string_of_method meth) (String.concat "/" path)) + (RPC.string_of_method meth) (String.concat "/" path)) (conv ~schema:Json_schema.any (fun exn -> `A (List.map json_of_error exn)) @@ -68,7 +68,7 @@ module Blocks = struct | `Head of int | `Prevalidation | `Test_head of int | `Test_prevalidation | `Hash of Block_hash.t - ] + ] type block_info = { hash: Block_hash.t ; @@ -367,8 +367,8 @@ module Blocks = struct (include_ops, length, heads, monitor, delay, min_date, min_heads)) (fun (include_ops, length, heads, monitor, delay, min_date, min_heads) -> - { include_ops ; length ; heads ; monitor ; - delay ; min_date ; min_heads }) + { include_ops ; length ; heads ; monitor ; + delay ; min_date ; min_heads }) (obj7 (dft "include_ops" (Data_encoding.describe diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index fef5d7d1e..c1c2d7d42 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -26,7 +26,7 @@ module Blocks : sig | `Head of int | `Prevalidation | `Test_head of int | `Test_prevalidation | `Hash of Block_hash.t - ] + ] val blocks_arg : block RPC.Arg.arg val parse_block: string -> (block, string) result diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index b6cdc1bea..9226e1122 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -78,7 +78,7 @@ let create net_db = Chain_traversal.live_blocks !head (State.Block.max_operations_ttl !head) - >>= fun (live_blocks, live_operations) -> + >>= fun (live_blocks, live_operations) -> let live_blocks = ref live_blocks in let live_operations = ref live_operations in let running_validation = ref Lwt.return_unit in diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index df9054930..5886f81bf 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -38,7 +38,7 @@ let () = (function Bad_data_dir -> Some () | _ -> None) (fun () -> Bad_data_dir) ; -(** *) + (** *) module Shared = struct type 'a t = { @@ -689,10 +689,10 @@ module Register_embedded_protocol end let read - ?patch_context - ~store_root - ~context_root - () = + ?patch_context + ~store_root + ~context_root + () = Store.init store_root >>=? fun global_store -> Context.init ?patch_context ~root:context_root >>= fun context_index -> let global_data = { diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 075333037..26035aa4f 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -146,17 +146,17 @@ let rec may_set_head v (block: State.Block.t) = (** Block validation *) type error += - | Invalid_operation of Operation_hash.t - | Invalid_fitness of { block: Block_hash.t ; - expected: Fitness.t ; - found: Fitness.t } - | Unknown_protocol - | Non_increasing_timestamp - | Non_increasing_fitness - | Wrong_level of Int32.t * Int32.t - | Wrong_proto_level of int * int - | Replayed_operation of Operation_hash.t - | Outdated_operation of Operation_hash.t * Block_hash.t + | Invalid_operation of Operation_hash.t + | Invalid_fitness of { block: Block_hash.t ; + expected: Fitness.t ; + found: Fitness.t } + | Unknown_protocol + | Non_increasing_timestamp + | Non_increasing_fitness + | Wrong_level of Int32.t * Int32.t + | Wrong_proto_level of int * int + | Replayed_operation of Operation_hash.t + | Outdated_operation of Operation_hash.t * Block_hash.t let () = Error_monad.register_error_kind @@ -168,7 +168,7 @@ let () = ~pp:(fun ppf (block, expected, found) -> Format.fprintf ppf "@[Invalid fitness for block %a@ \ - \ expected %a@ \ + \ expected %a@ \ \ found %a" Block_hash.pp_short block Fitness.pp expected @@ -365,110 +365,110 @@ let apply_block net_state db module Context_db = struct - type data = - { validator: net_validator ; - state: [ `Inited of Block_header.t tzresult - | `Initing of Block_header.t tzresult Lwt.t - | `Running of State.Block.t tzresult Lwt.t ] ; - wakener: State.Block.t tzresult Lwt.u } + type data = + { validator: net_validator ; + state: [ `Inited of Block_header.t tzresult + | `Initing of Block_header.t tzresult Lwt.t + | `Running of State.Block.t tzresult Lwt.t ] ; + wakener: State.Block.t tzresult Lwt.u } - type context = - { tbl : data Block_hash.Table.t ; - canceler : Lwt_utils.Canceler.t ; - worker_trigger: unit -> unit; - worker_waiter: unit -> unit Lwt.t ; - worker: unit Lwt.t ; - net_db : Distributed_db.net_db ; - net_state : State.Net.t } + type context = + { tbl : data Block_hash.Table.t ; + canceler : Lwt_utils.Canceler.t ; + worker_trigger: unit -> unit; + worker_waiter: unit -> unit Lwt.t ; + worker: unit Lwt.t ; + net_db : Distributed_db.net_db ; + net_state : State.Net.t } - let pending_requests { tbl } = - Block_hash.Table.fold - (fun h data acc -> - match data.state with - | `Initing _ -> acc - | `Running _ -> acc - | `Inited d -> (h, d, data) :: acc) - tbl [] + let pending_requests { tbl } = + Block_hash.Table.fold + (fun h data acc -> + match data.state with + | `Initing _ -> acc + | `Running _ -> acc + | `Inited d -> (h, d, data) :: acc) + tbl [] - let pending { tbl } hash = Block_hash.Table.mem tbl hash + let pending { tbl } hash = Block_hash.Table.mem tbl hash - let request validator { tbl ; worker_trigger ; net_db } hash = - assert (not (Block_hash.Table.mem tbl hash)); - let waiter, wakener = Lwt.wait () in - let data = - Distributed_db.Block_header.fetch net_db hash () in - match Lwt.state data with - | Lwt.Return data -> - let state = `Inited data in - Block_hash.Table.add tbl hash { validator ; state ; wakener } ; - worker_trigger () ; - waiter - | _ -> - let state = `Initing data in - Block_hash.Table.add tbl hash { validator ; state ; wakener } ; - Lwt.async - (fun () -> - data >>= fun data -> - let state = `Inited data in - Block_hash.Table.replace tbl hash { validator ; state ; wakener } ; - worker_trigger () ; - Lwt.return_unit) ; - waiter + let request validator { tbl ; worker_trigger ; net_db } hash = + assert (not (Block_hash.Table.mem tbl hash)); + let waiter, wakener = Lwt.wait () in + let data = + Distributed_db.Block_header.fetch net_db hash () in + match Lwt.state data with + | Lwt.Return data -> + let state = `Inited data in + Block_hash.Table.add tbl hash { validator ; state ; wakener } ; + worker_trigger () ; + waiter + | _ -> + let state = `Initing data in + Block_hash.Table.add tbl hash { validator ; state ; wakener } ; + Lwt.async + (fun () -> + data >>= fun data -> + let state = `Inited data in + Block_hash.Table.replace tbl hash { validator ; state ; wakener } ; + worker_trigger () ; + Lwt.return_unit) ; + waiter - let prefetch validator ({ net_state ; tbl } as session) hash = - Lwt.ignore_result - (State.Block.known_valid net_state hash >>= fun exists -> - if not exists && not (Block_hash.Table.mem tbl hash) then - request validator session hash >>= fun _ -> Lwt.return_unit - else - Lwt.return_unit) + let prefetch validator ({ net_state ; tbl } as session) hash = + Lwt.ignore_result + (State.Block.known_valid net_state hash >>= fun exists -> + if not exists && not (Block_hash.Table.mem tbl hash) then + request validator session hash >>= fun _ -> Lwt.return_unit + else + Lwt.return_unit) - let known { net_state } hash = - State.Block.known_valid net_state hash + let known { net_state } hash = + State.Block.known_valid net_state hash - let read { net_state } hash = - State.Block.read net_state hash + let read { net_state } hash = + State.Block.read net_state hash - let fetch ({ net_state ; tbl } as session) validator hash = - try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener - with Not_found -> - State.Block.known_invalid net_state hash >>= fun known_invalid -> - if known_invalid then - Lwt.return (Error [failure "Invalid predecessor"]) - else - State.Block.read_opt net_state hash >>= function - | Some op -> - Lwt.return (Ok op) + let fetch ({ net_state ; tbl } as session) validator hash = + try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener + with Not_found -> + State.Block.known_invalid net_state hash >>= fun known_invalid -> + if known_invalid then + Lwt.return (Error [failure "Invalid predecessor"]) + else + State.Block.read_opt net_state hash >>= function + | Some op -> + Lwt.return (Ok op) + | None -> + try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener + with Not_found -> request validator session hash + + let store { net_db ; tbl } hash data = + begin + match data with + | Ok data -> begin + Distributed_db.commit_block net_db hash data >>=? function | None -> - try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener - with Not_found -> request validator session hash - - let store { net_db ; tbl } hash data = - begin - match data with - | Ok data -> begin - Distributed_db.commit_block net_db hash data >>=? function - | None -> - (* Should not happen if the block is not validated twice *) - assert false - | Some block -> - return (Ok block) - end - | Error err -> - Distributed_db.commit_invalid_block net_db hash >>=? fun changed -> - assert changed ; - return (Error err) - end >>= function - | Ok block -> - let wakener = (Block_hash.Table.find tbl hash).wakener in - Block_hash.Table.remove tbl hash; - Lwt.wakeup wakener block ; - Lwt.return_unit - | Error _ as err -> - let wakener = (Block_hash.Table.find tbl hash).wakener in - Block_hash.Table.remove tbl hash; - Lwt.wakeup wakener err ; - Lwt.return_unit + (* Should not happen if the block is not validated twice *) + assert false + | Some block -> + return (Ok block) + end + | Error err -> + Distributed_db.commit_invalid_block net_db hash >>=? fun changed -> + assert changed ; + return (Error err) + end >>= function + | Ok block -> + let wakener = (Block_hash.Table.find tbl hash).wakener in + Block_hash.Table.remove tbl hash; + Lwt.wakeup wakener block ; + Lwt.return_unit + | Error _ as err -> + let wakener = (Block_hash.Table.find tbl hash).wakener in + Block_hash.Table.remove tbl hash; + Lwt.wakeup wakener err ; + Lwt.return_unit let process (v: net_validator) ~get_context ~set_context hash block = let net_state = Distributed_db.net_state v.net_db in @@ -482,7 +482,7 @@ module Context_db = struct begin Chain.genesis net_state >>= fun genesis -> if Block_hash.equal (State.Block.hash genesis) - block.shell.predecessor then + block.shell.predecessor then Lwt.return genesis else State.Block.read_exn net_state block.shell.predecessor @@ -524,38 +524,38 @@ module Context_db = struct return block let request session ~get_context ~set_context pendings = - let time = Time.now () in - let min_block b pb = - match pb with - | None -> Some b - | Some pb - when b.Block_header.shell.timestamp - < pb.Block_header.shell.timestamp -> - Some b - | Some _ as pb -> pb in - let next = - List.fold_left - (fun acc (hash, block, (data : data)) -> - match block with - | Error _ -> + let time = Time.now () in + let min_block b pb = + match pb with + | None -> Some b + | Some pb + when b.Block_header.shell.timestamp + < pb.Block_header.shell.timestamp -> + Some b + | Some _ as pb -> pb in + let next = + List.fold_left + (fun acc (hash, block, (data : data)) -> + match block with + | Error _ -> + acc + | Ok block -> + if Time.(block.Block_header.shell.timestamp > time) then + min_block block acc + else begin + Block_hash.Table.replace session.tbl hash { data with state = `Running begin + Lwt_main.yield () >>= fun () -> + process data.validator ~get_context ~set_context hash block >>= fun res -> + Block_hash.Table.remove session.tbl hash ; + Lwt.return res + end } ; acc - | Ok block -> - if Time.(block.Block_header.shell.timestamp > time) then - min_block block acc - else begin - Block_hash.Table.replace session.tbl hash { data with state = `Running begin - Lwt_main.yield () >>= fun () -> - process data.validator ~get_context ~set_context hash block >>= fun res -> - Block_hash.Table.remove session.tbl hash ; - Lwt.return res - end } ; - acc - end) - None - pendings in - match next with - | None -> 0. - | Some b -> Int64.to_float (Time.diff b.Block_header.shell.timestamp time) + end) + None + pendings in + match next with + | None -> 0. + | Some b -> Int64.to_float (Time.diff b.Block_header.shell.timestamp time) let create net_db = let net_state = Distributed_db.net_state net_db in @@ -649,7 +649,7 @@ let create_validator ?parent worker ?max_child_ttl state db net = ( Lwt_unix.sleep 30. >|= fun () -> None) ] >>= function | Some block when Time.((State.Block.header block).shell.timestamp < add (Time.now ()) (-60L)) -> - wait () + wait () | _ -> Chain.head net >>= fun head -> Chain.genesis net >>= fun genesis -> @@ -891,7 +891,7 @@ let create state db = fetch_block net hash else failwith "Fitness is below the current one" - end in + end in return (hash, validation) in let rec activate ?parent ?max_child_ttl net = diff --git a/src/node/shell/validator.mli b/src/node/shell/validator.mli index 26868554e..912aa0d49 100644 --- a/src/node/shell/validator.mli +++ b/src/node/shell/validator.mli @@ -17,8 +17,8 @@ val notify_block: t -> Block_hash.t -> Block_header.t -> unit Lwt.t type net_validator type error += - | Non_increasing_timestamp - | Non_increasing_fitness + | Non_increasing_timestamp + | Non_increasing_fitness val activate: t -> ?max_child_ttl:int -> State.Net.t -> net_validator Lwt.t val get: t -> Net_id.t -> net_validator tzresult Lwt.t diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index c4b3e3fa8..2128819d7 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -118,4 +118,4 @@ module LiftProtocol(Name : sig val name: string end) (Env : Node_protocol_environment_sigs.V1) (P : Env.Updater.PROTOCOL) : NODE_PROTOCOL with type operation := P.operation - and type validation_state := P.validation_state + and type validation_state := P.validation_state diff --git a/src/proto/alpha/amendment.ml b/src/proto/alpha/amendment.ml index 79c4b8dd3..758d6e9b0 100644 --- a/src/proto/alpha/amendment.ml +++ b/src/proto/alpha/amendment.ml @@ -38,7 +38,7 @@ let check_approval_and_update_quorum ctxt = let updated_quorum = Int32.div (Int32.add (Int32.mul 8l expected_quorum) - (Int32.mul 2l actual_quorum)) + (Int32.mul 2l actual_quorum)) 10l in Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt -> return diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index 4b715dca8..c4f2856a7 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -189,9 +189,9 @@ let apply_sourced_operation let delegate = Ed25519.Public_key.hash source in check_signature_and_update_public_key ctxt delegate (Some source) operation >>=? fun ctxt -> - (* TODO, see how to extract the public key hash after this operation to - pass it to apply_delegate_operation_content *) - fold_left_s (fun ctxt content -> + (* TODO, see how to extract the public key hash after this operation to + pass it to apply_delegate_operation_content *) + fold_left_s (fun ctxt content -> apply_delegate_operation_content ctxt delegate pred_block block_prio content) ctxt contents >>=? fun ctxt -> diff --git a/src/proto/alpha/baking.ml b/src/proto/alpha/baking.ml index 4293e98da..09b607d21 100644 --- a/src/proto/alpha/baking.ml +++ b/src/proto/alpha/baking.ml @@ -26,8 +26,8 @@ let () = ~description:"The block timestamp is before the first slot \ for this baker at this level" ~pp:(fun ppf (r, p) -> - Format.fprintf ppf "Block forged too early (%a is before %a)" - Time.pp_hum p Time.pp_hum r) + Format.fprintf ppf "Block forged too early (%a is before %a)" + Time.pp_hum p Time.pp_hum r) Data_encoding.(obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding)) @@ -102,12 +102,12 @@ let minimal_time c priority pred_timestamp = else match durations with | [] -> cumsum_slot_durations acc [ Period.one_minute ] p | [ last ] -> - Period.mult p last >>? fun period -> - Timestamp.(acc +? period) + Period.mult p last >>? fun period -> + Timestamp.(acc +? period) | first :: durations -> - Timestamp.(acc +? first) >>? fun acc -> - let p = Int32.pred p in - cumsum_slot_durations acc durations p in + Timestamp.(acc +? first) >>? fun acc -> + let p = Int32.pred p in + cumsum_slot_durations acc durations p in Lwt.return (cumsum_slot_durations pred_timestamp (Constants.slot_durations c) (Int32.succ priority)) diff --git a/src/proto/alpha/block_header_repr.ml b/src/proto/alpha/block_header_repr.ml index c037ed104..5a963a8e1 100644 --- a/src/proto/alpha/block_header_repr.ml +++ b/src/proto/alpha/block_header_repr.ml @@ -40,10 +40,10 @@ let proto_header_encoding = (fun (priority, seed_nonce_hash, proof_of_work_nonce) -> { priority ; seed_nonce_hash ; proof_of_work_nonce }) (obj3 - (req "priority" uint16) - (req "seed_nonce_hash" Nonce_hash.encoding) - (req "proof_of_work_nonce" - (Fixed.bytes Constants_repr.proof_of_work_nonce_size))) + (req "priority" uint16) + (req "seed_nonce_hash" Nonce_hash.encoding) + (req "proof_of_work_nonce" + (Fixed.bytes Constants_repr.proof_of_work_nonce_size))) let signed_proto_header_encoding = let open Data_encoding in diff --git a/src/proto/alpha/constants_repr.ml b/src/proto/alpha/constants_repr.ml index fb370fdc5..097ed2b0b 100644 --- a/src/proto/alpha/constants_repr.ml +++ b/src/proto/alpha/constants_repr.ml @@ -164,20 +164,20 @@ let constants_encoding = dictator_pubkey = unopt default.dictator_pubkey dictator_pubkey ; } ) - Data_encoding.( - merge_objs - (obj10 - (opt "cycle_length" int32) - (opt "voting_period_length" int32) - (opt "time_before_reward" int64) - (opt "slot_durations" (list Period_repr.encoding)) - (opt "first_free_baking_slot" uint16) - (opt "max_signing_slot" uint16) - (opt "instructions_per_transaction" int31) - (opt "proof_of_work_threshold" int64) - (opt "bootstrap_keys" (list Ed25519.Public_key.encoding)) - (opt "dictator_pubkey" Ed25519.Public_key.encoding)) - unit) + Data_encoding.( + merge_objs + (obj10 + (opt "cycle_length" int32) + (opt "voting_period_length" int32) + (opt "time_before_reward" int64) + (opt "slot_durations" (list Period_repr.encoding)) + (opt "first_free_baking_slot" uint16) + (opt "max_signing_slot" uint16) + (opt "instructions_per_transaction" int31) + (opt "proof_of_work_threshold" int64) + (opt "bootstrap_keys" (list Ed25519.Public_key.encoding)) + (opt "dictator_pubkey" Ed25519.Public_key.encoding)) + unit) type error += Constant_read of exn diff --git a/src/proto/alpha/cycle_repr.ml b/src/proto/alpha/cycle_repr.ml index 3e2446574..7fa2cd402 100644 --- a/src/proto/alpha/cycle_repr.ml +++ b/src/proto/alpha/cycle_repr.ml @@ -12,17 +12,17 @@ type cycle = t let encoding = Data_encoding.int32 let arg = - let construct = Int32.to_string in - let destruct str = - match Int32.of_string str with - | exception _ -> Error "Cannot parse cycle" - | cycle -> Ok cycle in - RPC.Arg.make - ~descr:"A cycle integer" - ~name: "block_cycle" - ~construct - ~destruct - () + let construct = Int32.to_string in + let destruct str = + match Int32.of_string str with + | exception _ -> Error "Cannot parse cycle" + | cycle -> Ok cycle in + RPC.Arg.make + ~descr:"A cycle integer" + ~name: "block_cycle" + ~construct + ~destruct + () let pp ppf cycle = Format.fprintf ppf "%ld" cycle diff --git a/src/proto/alpha/level_repr.ml b/src/proto/alpha/level_repr.ml index e99abbfb2..2f571873d 100644 --- a/src/proto/alpha/level_repr.ml +++ b/src/proto/alpha/level_repr.ml @@ -42,7 +42,7 @@ let encoding = voting_period, voting_period_position) -> { level ; level_position ; cycle ; cycle_position ; - voting_period ; voting_period_position }) + voting_period ; voting_period_position }) (obj6 (req "level" Raw_level_repr.encoding) (req "level_position" int32) diff --git a/src/proto/alpha/main.ml b/src/proto/alpha/main.ml index 146371d8f..ae3f0f8d2 100644 --- a/src/proto/alpha/main.ml +++ b/src/proto/alpha/main.ml @@ -78,7 +78,7 @@ let begin_construction ~timestamp ?proto_header () = - let level = Int32.succ pred_level in + let level = Int32.succ pred_level in let fitness = pred_fitness in Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt -> begin diff --git a/src/proto/alpha/nonce_storage.ml b/src/proto/alpha/nonce_storage.ml index f993601fb..b926437dc 100644 --- a/src/proto/alpha/nonce_storage.ml +++ b/src/proto/alpha/nonce_storage.ml @@ -36,8 +36,8 @@ let get_unrevealed c level = return (nonce_hash, delegate_to_reward, reward_amount) (* let get_unrevealed_hash c level = *) - (* get_unrevealed c level >>=? fun (nonce_hash, _) -> *) - (* return nonce_hash *) +(* get_unrevealed c level >>=? fun (nonce_hash, _) -> *) +(* return nonce_hash *) let record_hash c delegate_to_reward reward_amount nonce_hash = let level = Level_storage.current c in diff --git a/src/proto/alpha/operation_repr.ml b/src/proto/alpha/operation_repr.ml index 6f58072da..69ad3adb6 100644 --- a/src/proto/alpha/operation_repr.ml +++ b/src/proto/alpha/operation_repr.ml @@ -339,8 +339,8 @@ let encoding = (merge_objs (obj1 (req "hash" Operation_hash.encoding)) (merge_objs - Operation.shell_header_encoding - Encoding.signed_proto_operation_encoding)) + Operation.shell_header_encoding + Encoding.signed_proto_operation_encoding)) let () = register_error_kind diff --git a/src/proto/alpha/qty_repr.ml b/src/proto/alpha/qty_repr.ml index 15a54f1af..9ae8edb31 100644 --- a/src/proto/alpha/qty_repr.ml +++ b/src/proto/alpha/qty_repr.ml @@ -152,13 +152,13 @@ module Make (T: QTY) : S = struct let open Int64 in let rec step cur pow acc = if cur = 0L then - ok acc + ok acc else - pow +? pow >>? fun npow -> + pow +? pow >>? fun npow -> if logand cur 1L = 1L then acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc - else + else step (shift_right_logical cur 1) npow acc in if m < 0L then error (Negative_multiplicator (t, m)) diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index 51f22ff85..e495bf62d 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -57,7 +57,7 @@ let () = (fun (contract, expr) -> Runtime_contract_error (contract, expr)); -(* ---- interpreter ---------------------------------------------------------*) + (* ---- interpreter ---------------------------------------------------------*) type 'tys stack = | Item : 'ty * 'rest stack -> ('ty * 'rest) stack @@ -162,8 +162,8 @@ let rec interp (init, qta, ctxt, origination) l >>=? fun (res, qta, ctxt, origination) -> logged_return ~origination (Item (res, rest), qta, ctxt) | List_size, Item (list, rest) -> - let len = List.length list in - let len = Script_int.(abs (of_int len)) in + let len = List.length list in + let len = Script_int.(abs (of_int len)) in logged_return (Item (len, rest), qta - 1, ctxt) | List_iter body, Item (l, init_stack) -> fold_left_s diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index db991ace5..f02c8c769 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -231,13 +231,13 @@ let compare_comparable | Tez_key -> Tez.compare x y | Key_hash_key -> Ed25519.Public_key_hash.compare x y | Int_key -> - let res = (Script_int.compare x y) in + let res = (Script_int.compare x y) in if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1 | Nat_key -> - let res = (Script_int.compare x y) in + let res = (Script_int.compare x y) in if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1 @@ -968,14 +968,14 @@ let rec parse_data (fun (last_value, set) v -> parse_comparable_data ?type_logger ctxt t v >>=? fun v -> begin match last_value with - | Some value -> - if Compare.Int.(0 <= (compare_comparable t value v)) - then - if Compare.Int.(0 = (compare_comparable t value v)) - then fail (Duplicate_set_values (loc, strip_locations expr)) - else fail (Unordered_set_values (loc, strip_locations expr)) - else return () - | None -> return () + | Some value -> + if Compare.Int.(0 <= (compare_comparable t value v)) + then + if Compare.Int.(0 = (compare_comparable t value v)) + then fail (Duplicate_set_values (loc, strip_locations expr)) + else fail (Unordered_set_values (loc, strip_locations expr)) + else return () + | None -> return () end >>=? fun () -> return (Some v, set_update v true set)) (None, empty_set t) vs >>|? snd |> traced @@ -984,28 +984,28 @@ let rec parse_data (* Maps *) | Map_t (tk, tv), (Prim (loc, D_Map, vs, _) as expr) -> (fold_left_s - (fun (last_value, map) -> function - | Prim (_, D_Item, [ k; v ], _) -> - parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> - parse_data ?type_logger ctxt tv v >>=? fun v -> - begin match last_value with - | Some value -> - if Compare.Int.(0 <= (compare_comparable tk value k)) - then - if Compare.Int.(0 = (compare_comparable tk value k)) - then fail (Duplicate_map_keys (loc, strip_locations expr)) - else fail (Unordered_map_keys (loc, strip_locations expr)) - else return () - | None -> return () - end >>=? fun () -> - return (Some k, map_update k (Some v) map) - | Prim (loc, D_Item, l, _) -> - fail @@ Invalid_arity (loc, D_Item, 2, List.length l) - | Prim (loc, name, _, _) -> - fail @@ Invalid_primitive (loc, [ D_Item ], name) - | Int _ | String _ | Seq _ -> - fail (error ())) - (None, empty_map tk) vs) >>|? snd |> traced + (fun (last_value, map) -> function + | Prim (_, D_Item, [ k; v ], _) -> + parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> + parse_data ?type_logger ctxt tv v >>=? fun v -> + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable tk value k)) + then + if Compare.Int.(0 = (compare_comparable tk value k)) + then fail (Duplicate_map_keys (loc, strip_locations expr)) + else fail (Unordered_map_keys (loc, strip_locations expr)) + else return () + | None -> return () + end >>=? fun () -> + return (Some k, map_update k (Some v) map) + | Prim (loc, D_Item, l, _) -> + fail @@ Invalid_arity (loc, D_Item, 2, List.length l) + | Prim (loc, name, _, _) -> + fail @@ Invalid_primitive (loc, [ D_Item ], name) + | Int _ | String _ | Seq _ -> + fail (error ())) + (None, empty_map tk) vs) >>|? snd |> traced | Map_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Map ])) @@ -1819,7 +1819,7 @@ type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script let parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Script.t -> ex_script tzresult Lwt.t + context -> Script.t -> ex_script tzresult Lwt.t = fun ?type_logger ctxt { code ; storage } -> Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> trace @@ -1885,7 +1885,7 @@ let typecheck_code let typecheck_data : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> - context -> Script.expr * Script.expr -> unit tzresult Lwt.t + context -> Script.expr * Script.expr -> unit tzresult Lwt.t = fun ?type_logger ctxt (data, exp_ty) -> trace (Ill_formed_type (None, exp_ty, 0)) @@ -1898,13 +1898,13 @@ let typecheck_data (* ---- Error registration --------------------------------------------------*) let ex_ty_enc = - Data_encoding.conv - (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) - (fun expr -> - match parse_ty (root expr) with - | Ok (Ex_ty ty, _) -> Ex_ty ty - | _ -> Ex_ty Unit_t (* FIXME: ? *)) - Script.expr_encoding + Data_encoding.conv + (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) + (fun expr -> + match parse_ty (root expr) with + | Ok (Ex_ty ty, _) -> Ex_ty ty + | _ -> Ex_ty Unit_t (* FIXME: ? *)) + Script.expr_encoding let () = let open Data_encoding in @@ -2158,8 +2158,8 @@ let () = ~title:"Types contain inconsistent annotations" ~description:"The two types contain annotations that do not match" (located (obj2 - (req "type1" ex_ty_enc) - (req "type2" ex_ty_enc))) + (req "type1" ex_ty_enc) + (req "type2" ex_ty_enc))) (function | Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (Ex_ty ty1, Ex_ty ty2)) | _ -> None) @@ -2295,8 +2295,8 @@ let () = ~description: "The body of a map block did not match the expected type" (obj2 - (req "loc" Script.location_encoding) - (req "bodyType" ex_stack_ty_enc)) + (req "loc" Script.location_encoding) + (req "bodyType" ex_stack_ty_enc)) (function | Invalid_map_body (loc, stack) -> Some (loc, Ex_stack_ty stack) diff --git a/src/proto/alpha/script_typed_ir.ml b/src/proto/alpha/script_typed_ir.ml index dfe1e7f59..58a81a246 100644 --- a/src/proto/alpha/script_typed_ir.ml +++ b/src/proto/alpha/script_typed_ir.ml @@ -303,7 +303,7 @@ and ('bef, 'aft) instr = | Ge : (z num * 'rest, bool * 'rest) instr - (* protocol *) + (* protocol *) | Manager : (('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr | Transfer_tokens : 'sto ty -> @@ -315,7 +315,7 @@ and ('bef, 'aft) instr = (public_key_hash * 'rest, (unit, unit) typed_contract * 'rest) instr | Create_contract : 'g ty * 'p ty * 'r ty -> (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * - (('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))), + (('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))), ('p, 'r) typed_contract * 'rest) instr | Now : ('rest, Script_timestamp.t * 'rest) instr diff --git a/src/proto/alpha/services.ml b/src/proto/alpha/services.ml index 6573016eb..db2f03022 100644 --- a/src/proto/alpha/services.ml +++ b/src/proto/alpha/services.ml @@ -167,7 +167,7 @@ module Context = struct ~input: empty ~output: (wrap_tzerror @@ - (obj1 + (obj1 (req "voting_period_kind" Voting_period.kind_encoding))) RPC.Path.(custom_root / "context" / "voting_period_kind") @@ -195,20 +195,20 @@ module Context = struct (fun () -> Forgotten) ; ] - let get custom_root = - RPC.service - ~description: "Info about the nonce of a previous block." - ~input: empty - ~output: (wrap_tzerror nonce_encoding) - RPC.Path.(custom_root / "context" / "nonce" /: Raw_level.arg) + let get custom_root = + RPC.service + ~description: "Info about the nonce of a previous block." + ~input: empty + ~output: (wrap_tzerror nonce_encoding) + RPC.Path.(custom_root / "context" / "nonce" /: Raw_level.arg) - let hash custom_root = - RPC.service - ~description: "Hash of the current block's nonce." - ~input: empty - ~output: (wrap_tzerror @@ - describe ~title: "nonce hash" Nonce_hash.encoding) - RPC.Path.(custom_root / "context" / "nonce") + let hash custom_root = + RPC.service + ~description: "Hash of the current block's nonce." + ~input: empty + ~output: (wrap_tzerror @@ + describe ~title: "nonce hash" Nonce_hash.encoding) + RPC.Path.(custom_root / "context" / "nonce") end diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index 9f03e3574..24129bc6c 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -234,10 +234,10 @@ let minimal_timestamp ctxt prio = Baking.minimal_time ctxt prio let () = register1 - Services.Helpers.minimal_timestamp - (fun ctxt slot -> - let timestamp = Tezos_context.Timestamp.current ctxt in - minimal_timestamp ctxt slot timestamp) + Services.Helpers.minimal_timestamp + (fun ctxt slot -> + let timestamp = Tezos_context.Timestamp.current ctxt in + minimal_timestamp ctxt slot timestamp) let () = (* ctxt accept_failing_script baker_contract pred_block block_prio operation *) @@ -355,7 +355,7 @@ let () = Lwt_list.filter_map_p (fun x -> x) @@ List.mapi (fun prio c -> - let timestamp = Timestamp.current ctxt in + let timestamp = Timestamp.current ctxt in Baking.minimal_time ctxt prio timestamp >>= function | Error _ -> Lwt.return None | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp))) @@ -507,9 +507,9 @@ let check_signature ctxt signature shell contents = Operation.check_signature source { signature ; shell ; contents ; hash = dummy_hash } | Sourced_operations (Dictator_operation _) -> - let key = Constants.dictator_pubkey ctxt in - Operation.check_signature key - { signature ; shell ; contents ; hash = dummy_hash } + let key = Constants.dictator_pubkey ctxt in + Operation.check_signature key + { signature ; shell ; contents ; hash = dummy_hash } let parse_operations ctxt (operations, check) = map_s begin fun raw -> diff --git a/src/proto/alpha/storage.ml b/src/proto/alpha/storage.ml index e89353d19..4adf6e3f7 100644 --- a/src/proto/alpha/storage.ml +++ b/src/proto/alpha/storage.ml @@ -88,15 +88,15 @@ let prepare ~level ~timestamp ~fitness ctxt = may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) -> get_sandboxed ctxt >>=? fun sandbox -> Constants_repr.read sandbox >>=? function constants -> - let level = - Level_repr.from_raw - ~first_level - ~cycle_length:constants.Constants_repr.cycle_length - ~voting_period_length:constants.Constants_repr.voting_period_length - level in - return ({ context = ctxt ; constants ; level ; - timestamp ; fitness ; first_level}, - first_block) + let level = + Level_repr.from_raw + ~first_level + ~cycle_length:constants.Constants_repr.cycle_length + ~voting_period_length:constants.Constants_repr.voting_period_length + level in + return ({ context = ctxt ; constants ; level ; + timestamp ; fitness ; first_level}, + first_block) let recover { context } : Context.t = context let first_level { first_level } = first_level @@ -241,7 +241,7 @@ module Roll = struct let encoding = Ed25519.Public_key_hash.encoding end) - module Contract_roll_list = + module Contract_roll_list = Make_indexed_optional_data_storage(struct type key = Contract_repr.t type value = Roll_repr.t @@ -438,7 +438,7 @@ module Vote = struct let key = Key.Vote.ballots let name = "ballot" let encoding = Vote_repr.ballot_encoding - end) + end) end diff --git a/src/proto/alpha/storage_functors.ml b/src/proto/alpha/storage_functors.ml index 5c17a8eef..b17ac09c3 100644 --- a/src/proto/alpha/storage_functors.ml +++ b/src/proto/alpha/storage_functors.ml @@ -96,14 +96,14 @@ module Make_raw_data_storage (P : Raw_data_description) = struct let init ({ context = c } as s) k v = let key = key k in Context.get c key >>= - function - | Some _ -> - let msg - = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | None -> - Context.set c key (P.to_bytes v) >>= fun c -> - return { s with context = c } + function + | Some _ -> + let msg + = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | None -> + Context.set c key (P.to_bytes v) >>= fun c -> + return { s with context = c } (* Does not verify that the key is present or not *) let init_set ({ context = c } as s) k v = @@ -292,10 +292,10 @@ module Raw_make_iterable_data_storage module HashTbl = Persist.MakePersistentMap(Context)(K)(struct - type t = P.value - let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b - let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v - end) + type t = P.value + let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b + let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v + end) let key_to_string k = String.concat "/" (K.to_path k) @@ -329,14 +329,14 @@ module Raw_make_iterable_data_storage (* Verify that the key is not present before inserting *) let init ({ context = c } as s) k v = HashTbl.get c k >>= - function - | Some _ -> - let msg - = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | None -> - HashTbl.set c k v >>= fun c -> - return { s with context = c } + function + | Some _ -> + let msg + = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in + fail (Storage_error msg) + | None -> + HashTbl.set c k v >>= fun c -> + return { s with context = c } (* Does not verify that the key is present or not *) let init_set ({ context = c } as s) k v = diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index dca62c209..3131c8aa0 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -669,10 +669,10 @@ module Block_header : sig val forge_unsigned: Block_header.shell_header -> proto_header -> MBytes.t - (** [forge_header shell_hdr proto_hdr] is the binary serialization - (using [unsigned_header_encoding]) of a block header, - comprising both the shell and the protocol part of the header, - without the signature. *) + (** [forge_header shell_hdr proto_hdr] is the binary serialization + (using [unsigned_header_encoding]) of a block header, + comprising both the shell and the protocol part of the header, + without the signature. *) end diff --git a/src/proto/alpha/vote_repr.ml b/src/proto/alpha/vote_repr.ml index ae2d98fdf..d6cedb49d 100644 --- a/src/proto/alpha/vote_repr.ml +++ b/src/proto/alpha/vote_repr.ml @@ -11,7 +11,7 @@ type proposal = Protocol_hash.t (* votes can be for, against or neutral. -Neutral serves to count towards a quorum *) + Neutral serves to count towards a quorum *) type ballot = Yay | Nay | Pass let ballot_encoding = diff --git a/src/proto/alpha/vote_storage.ml b/src/proto/alpha/vote_storage.ml index 9daece03e..b0713c38f 100644 --- a/src/proto/alpha/vote_storage.ml +++ b/src/proto/alpha/vote_storage.ml @@ -33,7 +33,7 @@ let get_ballots ctxt = Storage.Vote.Ballots.fold ctxt ~f:(fun delegate ballot (ballots: ballots tzresult) -> Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> - let count = Int32.add weight in + let count = Int32.add weight in Lwt.return begin ballots >>? fun ballots -> match ballot with diff --git a/src/proto/demo/main.ml b/src/proto/demo/main.ml index 44f36dd02..584c58388 100644 --- a/src/proto/demo/main.ml +++ b/src/proto/demo/main.ml @@ -76,7 +76,7 @@ let begin_construction ~predecessor:_ ~timestamp:_ ?proto_header:_ () = - Fitness.to_int64 pred_fitness >>=? function pred_fitness -> + Fitness.to_int64 pred_fitness >>=? fun pred_fitness -> let fitness = Int64.succ pred_fitness in return { context ; fitness } diff --git a/src/proto/genesis/services.ml b/src/proto/genesis/services.ml index 22f571d0d..9fa40fdc2 100644 --- a/src/proto/genesis/services.ml +++ b/src/proto/genesis/services.ml @@ -66,8 +66,8 @@ let rpc_services : Updater.rpc_context RPC.directory = (Forge.block RPC.Path.root) (fun _ctxt ((net_id, level, proto_level, predecessor, timestamp, fitness), command) -> - let shell = { Block_header.net_id ; level ; proto_level ; predecessor ; - timestamp ; fitness ; validation_passes = 1 ; operations_hash } in - let bytes = Data.Command.forge shell command in - RPC.Answer.return bytes) in + let shell = { Block_header.net_id ; level ; proto_level ; predecessor ; + timestamp ; fitness ; validation_passes = 1 ; operations_hash } in + let bytes = Data.Command.forge shell command in + RPC.Answer.return bytes) in dir diff --git a/src/utils/IO.ml b/src/utils/IO.ml index 052e09e61..d594fed79 100644 --- a/src/utils/IO.ml +++ b/src/utils/IO.ml @@ -13,7 +13,7 @@ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) +*) open Error_monad diff --git a/src/utils/base58.ml b/src/utils/base58.ml index 6a954127b..962affebc 100644 --- a/src/utils/base58.ml +++ b/src/utils/base58.ml @@ -30,7 +30,7 @@ module Alphabet = struct if Bytes.get str char <> '\255' then Format.kasprintf invalid_arg "Base58: invalid alphabet (dup '%c' %d %d)" - (char_of_int char) (int_of_char @@ Bytes.get str char) i ; + (char_of_int char) (int_of_char @@ Bytes.get str char) i ; Bytes.set str char (char_of_int i) ; done ; { encode = alphabet ; decode = Bytes.to_string str } @@ -91,10 +91,10 @@ let raw_encode ?(alphabet=Alphabet.default) s = let s = Z.of_bits s in let rec loop s = if s = Z.zero then 0 else - let s, r = Z.div_rem s zbase in - let i = loop s in - Bytes.set res i (to_char ~alphabet (Z.to_int r)) ; - i + 1 in + let s, r = Z.div_rem s zbase in + let i = loop s in + Bytes.set res i (to_char ~alphabet (Z.to_int r)) ; + i + 1 in let i = loop s in let res = Bytes.sub_string res 0 i in String.make zeros zero ^ res @@ -105,9 +105,9 @@ let raw_decode ?(alphabet=Alphabet.default) s = let len = String.length s in let rec loop res i = if i = len then res else - let x = Z.of_int (of_char ~alphabet (String.get s i)) in - let res = Z.(add x (mul res zbase)) in - loop res (i+1) + let x = Z.of_int (of_char ~alphabet (String.get s i)) in + let res = Z.(add x (mul res zbase)) in + loop res (i+1) in let res = Z.to_bits @@ loop Z.zero zeros in let res_tzeros = count_trailing_char res '\000' in diff --git a/src/utils/crypto_box.ml b/src/utils/crypto_box.ml index 623ce9831..2e85bf4d0 100644 --- a/src/utils/crypto_box.ml +++ b/src/utils/crypto_box.ml @@ -36,13 +36,13 @@ let increment_nonce = Sodium.Box.increment_nonce let box = Sodium.Box.Bigbytes.box let box_open sk pk msg nonce = try Some (Sodium.Box.Bigbytes.box_open sk pk msg nonce) with - | Sodium.Verification_failure -> None + | Sodium.Verification_failure -> None let precompute = Sodium.Box.precompute let fast_box = Sodium.Box.Bigbytes.fast_box let fast_box_open ck msg nonce = try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with - | Sodium.Verification_failure -> None + | Sodium.Verification_failure -> None let compare_target hash target = let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in @@ -91,21 +91,21 @@ let generate_proof_of_work ?max pk target = let public_key_encoding = let open Data_encoding in - conv - Sodium.Box.Bigbytes.of_public_key - Sodium.Box.Bigbytes.to_public_key - (Fixed.bytes Sodium.Box.public_key_size) + conv + Sodium.Box.Bigbytes.of_public_key + Sodium.Box.Bigbytes.to_public_key + (Fixed.bytes Sodium.Box.public_key_size) let secret_key_encoding = let open Data_encoding in - conv - Sodium.Box.Bigbytes.of_secret_key - Sodium.Box.Bigbytes.to_secret_key - (Fixed.bytes Sodium.Box.secret_key_size) + conv + Sodium.Box.Bigbytes.of_secret_key + Sodium.Box.Bigbytes.to_secret_key + (Fixed.bytes Sodium.Box.secret_key_size) let nonce_encoding = let open Data_encoding in - conv - Sodium.Box.Bigbytes.of_nonce - Sodium.Box.Bigbytes.to_nonce - (Fixed.bytes Sodium.Box.nonce_size) + conv + Sodium.Box.Bigbytes.of_nonce + Sodium.Box.Bigbytes.to_nonce + (Fixed.bytes Sodium.Box.nonce_size) diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 21976961e..b7fabaee9 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -125,7 +125,7 @@ module Make() = struct let classify_error error = let rec find e = function | [] -> `Temporary - (* assert false (\* See "Generic error" *\) *) + (* assert false (\* See "Generic error" *\) *) | Error_kind { from_error ; category } :: rest -> match from_error e with | Some x -> begin @@ -368,72 +368,72 @@ module Make() = struct (Format.pp_print_list pp) (List.rev errors) -type error += Unclassified of string + type error += Unclassified of string -let () = - let id = "" in - let category = `Temporary in - let to_error msg = Unclassified msg in - let from_error = function - | Unclassified msg -> Some msg - | error -> - let msg = Obj.(extension_name @@ extension_constructor error) in - Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in - let title = "Generic error" in - let description = "An unclassified error" in - let encoding_case = - let open Data_encoding in - case - (describe ~title ~description @@ - conv (fun x -> ((), x)) (fun ((), x) -> x) @@ - (obj2 - (req "kind" (constant "generic")) - (req "error" string))) - from_error to_error in - let pp = Format.pp_print_string in - error_kinds := - Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds + let () = + let id = "" in + let category = `Temporary in + let to_error msg = Unclassified msg in + let from_error = function + | Unclassified msg -> Some msg + | error -> + let msg = Obj.(extension_name @@ extension_constructor error) in + Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in + let title = "Generic error" in + let description = "An unclassified error" in + let encoding_case = + let open Data_encoding in + case + (describe ~title ~description @@ + conv (fun x -> ((), x)) (fun ((), x) -> x) @@ + (obj2 + (req "kind" (constant "generic")) + (req "error" string))) + from_error to_error in + let pp = Format.pp_print_string in + error_kinds := + Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds -type error += Assert_error of string * string + type error += Assert_error of string * string -let () = - let id = "" in - let category = `Permanent in - let to_error (loc, msg) = Assert_error (loc, msg) in - let from_error = function - | Assert_error (loc, msg) -> Some (loc, msg) - | _ -> None in - let title = "Assertion error" in - let description = "An fatal assertion" in - let encoding_case = - let open Data_encoding in - case - (describe ~title ~description @@ - conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@ - (obj3 - (req "kind" (constant "assertion")) - (req "location" string) - (req "error" string))) - from_error to_error in - let pp ppf (loc, msg) = - Format.fprintf ppf - "Assert failure (%s)%s" - loc - (if msg = "" then "." else ": " ^ msg) in - error_kinds := - Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds + let () = + let id = "" in + let category = `Permanent in + let to_error (loc, msg) = Assert_error (loc, msg) in + let from_error = function + | Assert_error (loc, msg) -> Some (loc, msg) + | _ -> None in + let title = "Assertion error" in + let description = "An fatal assertion" in + let encoding_case = + let open Data_encoding in + case + (describe ~title ~description @@ + conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@ + (obj3 + (req "kind" (constant "assertion")) + (req "location" string) + (req "error" string))) + from_error to_error in + let pp ppf (loc, msg) = + Format.fprintf ppf + "Assert failure (%s)%s" + loc + (if msg = "" then "." else ": " ^ msg) in + error_kinds := + Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds -let _assert b loc fmt = - if b then - Format.ikfprintf (fun _ -> return ()) Format.str_formatter fmt - else - Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt + let _assert b loc fmt = + if b then + Format.ikfprintf (fun _ -> return ()) Format.str_formatter fmt + else + Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt -let protect ~on_error t = - t >>= function - | Ok res -> return res - | Error err -> on_error err + let protect ~on_error t = + t >>= function + | Ok res -> return res + | Error err -> on_error err end diff --git a/src/utils/hash.ml b/src/utils/hash.ml index 3a0833171..d54d648d1 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -251,14 +251,14 @@ module Make_minimal_Blake2B (K : Name) = struct module Table = struct include Hashtbl.Make(struct - type nonrec t = t - let hash s = - Int64.to_int - (EndianString.BigEndian.get_int64 - (Bytes.unsafe_to_string (Sodium.Generichash.Bytes.of_hash s)) - 0) - let equal = equal - end) + type nonrec t = t + let hash s = + Int64.to_int + (EndianString.BigEndian.get_int64 + (Bytes.unsafe_to_string (Sodium.Generichash.Bytes.of_hash s)) + 0) + let equal = equal + end) end end @@ -691,10 +691,10 @@ module Net_id = struct module Table = struct include Hashtbl.Make(struct - type nonrec t = t - let hash = Hashtbl.hash - let equal = equal - end) + type nonrec t = t + let hash = Hashtbl.hash + let equal = equal + end) end end diff --git a/src/utils/logging.ml b/src/utils/logging.ml index cd7dede9d..dc4a9c742 100644 --- a/src/utils/logging.ml +++ b/src/utils/logging.ml @@ -205,18 +205,18 @@ let close () = type level = Lwt_log_core.level = | Debug - (** Debugging message. They can be automatically removed by the - syntax extension. *) + (** Debugging message. They can be automatically removed by the + syntax extension. *) | Info - (** Informational message. Suitable to be displayed when the - program is in verbose mode. *) + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) | Notice - (** Same as {!Info}, but is displayed by default. *) + (** Same as {!Info}, but is displayed by default. *) | Warning - (** Something strange happend *) + (** Something strange happend *) | Error - (** An error message, which should not means the end of the - program. *) + (** An error message, which should not means the end of the + program. *) | Fatal let level_encoding = diff --git a/src/utils/logging.mli b/src/utils/logging.mli index e4eccc305..608caf523 100644 --- a/src/utils/logging.mli +++ b/src/utils/logging.mli @@ -49,18 +49,18 @@ module Make(S: sig val name: string end) : LOG type level = Lwt_log_core.level = | Debug - (** Debugging message. They can be automatically removed by the - syntax extension. *) + (** Debugging message. They can be automatically removed by the + syntax extension. *) | Info - (** Informational message. Suitable to be displayed when the - program is in verbose mode. *) + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) | Notice - (** Same as {!Info}, but is displayed by default. *) + (** Same as {!Info}, but is displayed by default. *) | Warning - (** Something strange happend *) + (** Something strange happend *) | Error - (** An error message, which should not means the end of the - program. *) + (** An error message, which should not means the end of the + program. *) | Fatal type template = Lwt_log.template diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 7e58f2a82..1d163a00f 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -313,12 +313,12 @@ let stable_sort cmp l = end end | n, l -> - let n1 = n asr 1 in - let n2 = n - n1 in - let l2 = chop n1 l in - rev_sort n1 l >>= fun s1 -> - rev_sort n2 l2 >>= fun s2 -> - rev_merge_rev s1 s2 [] + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + rev_sort n1 l >>= fun s1 -> + rev_sort n2 l2 >>= fun s2 -> + rev_merge_rev s1 s2 [] and rev_sort n l = match n, l with | 2, x1 :: x2 :: _ -> begin diff --git a/test/jbuild b/test/jbuild index dc7aabac6..2c822cb99 100644 --- a/test/jbuild +++ b/test/jbuild @@ -26,8 +26,8 @@ ../scripts/client_lib.inc.sh (glob_files contracts/*) )) - (locks (/tcp-port/18732 - /tcp-port/19732)) + (locks (/tcp-port/18731 + /tcp-port/19731)) (action (run bash ${path:test_contracts.sh})))) (alias @@ -46,3 +46,9 @@ /tcp-port/19731 /tcp-port/19732 /tcp-port/19733 /tcp-port/19734 /tcp-port/19735 /tcp-port/19736 /tcp-port/19737 /tcp-port/19738)) (action (run bash ${path:test_multinode.sh})))) + +(alias + ((name runtest) + (deps ((alias runtest_basic.sh) + (alias runtest_contracts.sh) + (alias runtest_multinode.sh))))) diff --git a/test/lib/test.ml b/test/lib/test.ml index cfc648961..61ab5af69 100644 --- a/test/lib/test.ml +++ b/test/lib/test.ml @@ -135,23 +135,23 @@ let run prefix tests = let res = Test.exec_test test in begin match res with - | Passed -> - incr passed; - incr total - | Failed _ -> - incr failed; - incr total - | Uncaught _ -> - incr uncaught; - incr total - | Report (pass, tot, unc, _, _) -> - passed := !passed + pass; - failed := !failed + (tot - pass -unc); - uncaught := !uncaught + unc; - total := !total + tot - | Exit_code c -> - incr (if c = 0 then passed else failed); - incr total + | Passed -> + incr passed; + incr total + | Failed _ -> + incr failed; + incr total + | Uncaught _ -> + incr uncaught; + incr total + | Report (pass, tot, unc, _, _) -> + passed := !passed + pass; + failed := !failed + (tot - pass -unc); + uncaught := !uncaught + unc; + total := !total + tot + | Exit_code c -> + incr (if c = 0 then passed else failed); + incr total end ; output title res ; flush stderr) diff --git a/test/p2p/test_p2p_connection_pool.ml b/test/p2p/test_p2p_connection_pool.ml index dfb297b0a..a3ace0c0d 100644 --- a/test/p2p/test_p2p_connection_pool.ml +++ b/test/p2p/test_p2p_connection_pool.ml @@ -63,25 +63,25 @@ let detach_node f points n = let identity = Identity.generate proof_of_work_target in let nb_points = List.length points in let config = P2p_connection_pool.{ - identity ; - proof_of_work_target ; - trusted_points = points ; - peers_file = "/dev/null" ; - closed_network = true ; - listening_port = Some port ; - min_connections = nb_points ; - max_connections = nb_points ; - max_incoming_connections = nb_points ; - authentification_timeout = 2. ; - incoming_app_message_queue_size = None ; - incoming_message_queue_size = None ; - outgoing_message_queue_size = None ; - known_peer_ids_history_size = 100 ; - known_points_history_size = 100 ; - max_known_points = None ; - max_known_peer_ids = None ; - swap_linger = 0. ; - binary_chunks_size = None + identity ; + proof_of_work_target ; + trusted_points = points ; + peers_file = "/dev/null" ; + closed_network = true ; + listening_port = Some port ; + min_connections = nb_points ; + max_connections = nb_points ; + max_incoming_connections = nb_points ; + authentification_timeout = 2. ; + incoming_app_message_queue_size = None ; + incoming_message_queue_size = None ; + outgoing_message_queue_size = None ; + known_peer_ids_history_size = 100 ; + known_points_history_size = 100 ; + max_known_points = None ; + max_known_peer_ids = None ; + swap_linger = 0. ; + binary_chunks_size = None } in Process.detach ~prefix:(Format.asprintf "%a: " Peer_id.pp_short identity.peer_id) diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index a1238fb7e..fc4e95643 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -14,11 +14,11 @@ let (//) = Filename.concat let () = Random.self_init () let rpc_config = ref { - Client_rpcs.host = "localhost" ; - port = 8192 + Random.int 8192 ; - tls = false ; - logger = Client_rpcs.null_logger ; -} + Client_rpcs.host = "localhost" ; + port = 8192 + Random.int 8192 ; + tls = false ; + logger = Client_rpcs.null_logger ; + } let dictator_sk = Ed25519.Secret_key.of_b58check_exn @@ -200,7 +200,7 @@ module Account = struct ~manager_pkh ~spendable ~balance - () = + () = let fee = match Tez.of_cents fee with | None -> Tez.zero | Some amount -> amount in @@ -330,13 +330,13 @@ module Assert = struct let failed_to_preapply ~msg ?op f = Assert.contain_error ~msg ~f:begin function | Client_baking_forge.Failed_to_preapply (op', err) -> - begin - match op with - | None -> true - | Some op -> - let h = hash op and h' = hash op' in - Operation_hash.equal h h' - end && List.exists (ecoproto_error f) err + begin + match op with + | None -> true + | Some op -> + let h = hash op and h' = hash op' in + Operation_hash.equal h h' + end && List.exists (ecoproto_error f) err | _ -> false end @@ -513,8 +513,8 @@ module Endorse = struct return result let endorsement_rights - ?(max_priority = 1024) - (contract : Account.t) block = + ?(max_priority = 1024) + (contract : Account.t) block = Client_proto_rpcs.Context.level !rpc_config block >>=? fun level -> let delegate = contract.pkh in let level = level.level in diff --git a/test/proto_alpha/test_michelson_parser.ml b/test/proto_alpha/test_michelson_parser.ml index 2f50d72f4..6cb3a6a9c 100644 --- a/test/proto_alpha/test_michelson_parser.ml +++ b/test/proto_alpha/test_michelson_parser.ml @@ -216,7 +216,7 @@ Assert.equal (get_tokens @@ tokenize @@ "string") let parse_expr_no_locs str = List.map strip_locations - Michelson_parser.(parse_toplevel (tokenize str)) + Michelson_parser.(parse_toplevel (tokenize str)) let assert_parses str parsed = Assert.equal (parse_expr_no_locs str) parsed;; @@ -247,8 +247,8 @@ assert_parses "PUSH (pair bool string) (Pair False \"abc\")" [ Prim ((), "bool", [], None) ; Prim ((), "string", [], None) ], None) ; Prim ((), "Pair", - [ Prim ((), "False", [], None) ; - String ((), "abc")], None) ], None) ]; + [ Prim ((), "False", [], None) ; + String ((), "abc")], None) ], None) ]; assert_parses "PUSH (list nat) (List 1 2 3)" [ Prim ((), "PUSH", [ Prim ((), "list", [ Prim ((), "nat", [], None) ], None) ; @@ -262,7 +262,7 @@ assert_parses "PUSH (lambda nat nat) {}" [ Prim ((), "nat", [], None); Prim ((), "nat", [], None)], None) ; Seq((), [], None)], - None) ]; + None) ]; assert_parses "PUSH key \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\"" [ Prim ((), "PUSH", [ Prim ((), "key", [], None) ; String ((),"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") ], @@ -278,9 +278,9 @@ assert_parses "PUSH (map int bool) (Map (Item 100 False))" None) ]; assert_parses "parameter int; \ -return int; \ + return int; \ storage unit; \ -code {}" + code {}" [ Prim ((), "parameter", [ Prim((), "int", [], None) ], None); Prim ((), "return", [ Prim((), "int", [], None) ], None); Prim ((), "storage", [ Prim((), "unit", [], None) ], None); diff --git a/test/test_contracts.sh b/test/test_contracts.sh index 51d0b78d8..c16ad21a1 100755 --- a/test/test_contracts.sh +++ b/test/test_contracts.sh @@ -6,7 +6,7 @@ set -o pipefail test_dir="$(cd "$(dirname "$0")" && echo "$(pwd -P)")" source $test_dir/lib/test_lib.inc.sh -start_node 2 +start_node 1 activate_alpha key1=foo diff --git a/test/utils/test_data_encoding.ml b/test/utils/test_data_encoding.ml index 34ec2d873..7e5097791 100644 --- a/test/utils/test_data_encoding.ml +++ b/test/utils/test_data_encoding.ml @@ -17,9 +17,9 @@ let is_invalid_arg = function | _ -> false let test_simple_json ?msg ?(equal=Assert.equal) encoding value = - let json = Json.construct encoding value in - let result = Json.destruct encoding json in - equal ?msg value result + let json = Json.construct encoding value in + let result = Json.destruct encoding json in + equal ?msg value result let test_simple_bin ?msg ?(equal=Assert.equal) encoding value = let bin = Binary.to_bytes encoding value in @@ -134,29 +134,29 @@ let prn_t = function | E -> "E" let test_tag_errors _ = - let duplicate_tag () = - union [ - case ~tag:1 - int8 - (fun i -> i) - (fun i -> Some i) ; - case ~tag:1 - int8 - (fun i -> i) - (fun i -> Some i)] in - Assert.test_fail ~msg:__LOC__ duplicate_tag - (function Duplicated_tag _ -> true - | _ -> false) ; - let invalid_tag () = - union [ - case ~tag:(2 lsl 7) - int8 - (fun i -> i) - (fun i -> Some i)] in - Assert.test_fail ~msg:__LOC__ invalid_tag - (function (Invalid_tag (_, `Uint8)) -> true - | _ -> false) ; - Lwt.return_unit + let duplicate_tag () = + union [ + case ~tag:1 + int8 + (fun i -> i) + (fun i -> Some i) ; + case ~tag:1 + int8 + (fun i -> i) + (fun i -> Some i)] in + Assert.test_fail ~msg:__LOC__ duplicate_tag + (function Duplicated_tag _ -> true + | _ -> false) ; + let invalid_tag () = + union [ + case ~tag:(2 lsl 7) + int8 + (fun i -> i) + (fun i -> Some i)] in + Assert.test_fail ~msg:__LOC__ invalid_tag + (function (Invalid_tag (_, `Uint8)) -> true + | _ -> false) ; + Lwt.return_unit let test_union _ = let enc = @@ -233,7 +233,7 @@ let test_splitted _ = case ~tag:2 s_enc (fun s -> Some { field = int_of_string s }) - (fun s -> string_of_int s.field) ; + (fun s -> string_of_int s.field) ; ])) in let get_result ~msg bin = match Binary.of_bytes enc bin with diff --git a/test/utils/test_lwt_pipe.ml b/test/utils/test_lwt_pipe.ml index 3b2e01926..55a09f99f 100644 --- a/test/utils/test_lwt_pipe.ml +++ b/test/utils/test_lwt_pipe.ml @@ -44,7 +44,7 @@ let main () = let anon_fun _ = () in let usage_msg = "Usage: %s .\nArguments are:" in Arg.parse spec anon_fun usage_msg; - run !qsize !nb_producers - !nb_consumers !produced_per_producer !consumed_per_consumer + run !qsize !nb_producers + !nb_consumers !produced_per_producer !consumed_per_consumer let () = Lwt_main.run @@ main () diff --git a/test/utils/test_stream_data_encoding.ml b/test/utils/test_stream_data_encoding.ml index c5e50259e..00e768daf 100644 --- a/test/utils/test_stream_data_encoding.ml +++ b/test/utils/test_stream_data_encoding.ml @@ -406,7 +406,7 @@ let test_splitted _ = case ~tag:2 s_enc (fun s -> Some { field = int_of_string s }) - (fun s -> string_of_int s.field) ; + (fun s -> string_of_int s.field) ; ])) in let get_result ~msg bin_l = let status = Binary.read_stream_of_bytes enc in