From d61220f4f9bd2a3bffca3c18b25a530080f2b6e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 14 Nov 2016 17:28:37 +0100 Subject: [PATCH] Compiler: use explicit functor in `Environment` Previously, the functor applications were hidden in a module generated by `tezos-protocol-compiler`. --- src/Makefile | 14 ++-- src/compiler/embedded_cmis.mli | 4 -- src/compiler/tezos_compiler.ml | 66 +++++++---------- src/node/updater/environment.ml | 94 ++++++++++++++----------- src/node/updater/environment_gen.ml | 10 ++- src/node/updater/proto_environment.ml | 10 ++- src/node/updater/register.ml | 3 +- src/node/updater/register.mli | 2 +- src/proto/bootstrap/.merlin | 4 +- src/proto/bootstrap/storage_functors.ml | 2 +- src/proto/demo/.merlin | 4 +- src/proto/environment/base48.mli | 10 +-- src/proto/environment/context.mli | 6 ++ 13 files changed, 113 insertions(+), 116 deletions(-) diff --git a/src/Makefile b/src/Makefile index 182a89f9c..91a81d37b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -30,8 +30,10 @@ $(addprefix proto/environment/, \ \ uri.mli \ data_encoding.mli \ + error_monad.mli \ + logging.mli \ time.mli \ - ../../utils/base48.mli \ + base48.mli \ hash.mli \ ed25519.mli \ persist.mli \ @@ -40,11 +42,7 @@ $(addprefix proto/environment/, \ \ fitness.mli \ updater.mli \ -) \ -utils/logging.mli \ -utils/error_monad_sig.ml \ -utils/error_monad.mli \ - +) .INTERMEDIATE: node/updater/environment_gen .SECONDARY: node/updater/proto_environment.mli @@ -75,10 +73,6 @@ clean:: EMBEDDED_PROTOCOL_LIB_CMIS := \ tmp/camlinternalFormatBasics.cmi \ - utils/error_monad.cmi \ - proto/environment/error_monad.mli \ - proto/environment/base48.mli \ - proto/environment/logging.mli \ node/updater/proto_environment.cmi \ node/updater/register.cmi diff --git a/src/compiler/embedded_cmis.mli b/src/compiler/embedded_cmis.mli index 8b4cc4a0e..cf01202eb 100644 --- a/src/compiler/embedded_cmis.mli +++ b/src/compiler/embedded_cmis.mli @@ -8,9 +8,5 @@ (**************************************************************************) val camlinternalFormatBasics_cmi: string -val error_monad_cmi: string -val error_monad_mli: string -val logging_mli: string -val base48_mli: string val proto_environment_cmi: string val register_cmi: string diff --git a/src/compiler/tezos_compiler.ml b/src/compiler/tezos_compiler.ml index 66eba9ed7..6f868a5cc 100644 --- a/src/compiler/tezos_compiler.ml +++ b/src/compiler/tezos_compiler.ml @@ -258,12 +258,14 @@ let link_shared ?(static=false) output objects = let create_register_file client file hash packname modules = let unit = List.hd (List.rev modules) in - let error_monad = packname ^ ".Local_modules.Error_monad" in - let base48 = packname ^ ".Local_modules.Base48" in + let environment_module = packname ^ ".Local_environment.Environment" in + let error_monad_module = environment_module ^ ".Error_monad" in + let context_module = environment_module ^ ".Context" in + let hash_module = environment_module ^ ".Hash" in create_file file (Printf.sprintf "module Packed_protocol = struct\n\ - \ let hash = (Hash.Protocol_hash.of_b48check %S)\n\ + \ let hash = (%s.Protocol_hash.of_b48check %S)\n\ \ type error = %s.error = ..\n\ \ type 'a tzresult = 'a %s.tzresult\n\ \ include %s.%s\n\ @@ -274,18 +276,20 @@ let create_register_file client file hash packname modules = \ end\n\ \ %s\n\ " + hash_module (Protocol_hash.to_b48check hash) - error_monad - error_monad + error_monad_module + error_monad_module packname (String.capitalize_ascii unit) - error_monad - error_monad - error_monad - base48 + error_monad_module + error_monad_module + error_monad_module + context_module (if client then "include Register.Make(Packed_protocol)" else - "let () = Register.register (module Packed_protocol : PACKED_PROTOCOL)")) + Printf.sprintf + "let () = Register.register (%s.__cast (module Packed_protocol : %s.PACKED_PROTOCOL))" environment_module environment_module)) let mktemp_dir () = Filename.get_temp_dir_name () // @@ -394,50 +398,30 @@ let main () = if keep_object then create_file (build_dir // ".tezos_compiler") (md5 ^ "\n"); - Compenv.implicit_modules := - if client then [ "Environment" ] else [ "Proto_environment" ] ; - (* Compile the /ad-hoc/ Error_monad. *) List.iter (dump_cmi sigs_dir) tezos_protocol_env ; at_exit (fun () -> List.iter (unlink_cmi sigs_dir) tezos_protocol_env ) ; - let local_modules_unit = "local_modules" in - let local_modules_ml = build_dir // local_modules_unit ^ ".ml" in - create_file local_modules_ml @@ Printf.sprintf {| - module Error_monad = struct - type error_category = [ `Branch | `Temporary | `Permanent ] - include Error_monad.Make() - end - module Logging = Logging.Make(struct let name = %S end) - module Base48 = struct - include Base48 - include Make(struct type context = Context.t end) - end + let local_environment_unit = "local_environment" in + let local_environment_ml = build_dir // local_environment_unit ^ ".ml" in + create_file local_environment_ml @@ Printf.sprintf {| + module Environment = %s.Make(struct let name = %S end)() |} + (if client then "Environment" else "Proto_environment") logname ; - let local_modules_mli = build_dir // local_modules_unit ^ ".mli" in - create_file local_modules_mli @@ Printf.sprintf {| - module Error_monad : sig %s end - module Logging : sig %s end - module Base48 : sig %s end - |} - Embedded_cmis.error_monad_mli - Embedded_cmis.logging_mli - Embedded_cmis.base48_mli ; if not keep_object then at_exit (fun () -> - safe_unlink local_modules_mli ; - safe_unlink local_modules_ml) ; - let local_modules_object = + safe_unlink local_environment_ml) ; + let local_environment_object = compile_units ~ctxt ~for_pack:packname ~keep_object - ~build_dir ~source_dir:build_dir [local_modules_unit] + ~build_dir ~source_dir:build_dir [local_environment_unit] in Compenv.implicit_modules := - !Compenv.implicit_modules @ - [ "Local_modules"; "Error_monad" ; "Hash" ; "Logging" ]; + [ "Local_environment"; "Environment" ; + "Error_monad" ; "Hash" ; "Logging" ]; (* Compile the protocol *) let objects = @@ -446,7 +430,7 @@ let main () = ~update_needed ~keep_object ~for_pack:packname ~build_dir ~source_dir units in pack_objects ~ctxt ~keep_object - packed_objects (local_modules_object @ objects) ; + packed_objects (local_environment_object @ objects) ; (* Compiler the 'registering module' *) List.iter (dump_cmi sigs_dir) register_env; diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml index 23ca178ab..015008fb9 100644 --- a/src/node/updater/environment.ml +++ b/src/node/updater/environment.ml @@ -7,30 +7,6 @@ (* *) (**************************************************************************) -include Pervasives -module Pervasives = Pervasives -module Compare = Compare -module Array = Array -module List = List -module Bytes = Bytes -module String = String -module Set = Set -module Map = Map -module Int32 = Int32 -module Int64 = Int64 -module Nativeint = Nativeint -module Buffer = Buffer -module Format = Format -module Hex_encode = Hex_encode -module Lwt_sequence = Lwt_sequence -module Lwt = Lwt -module Lwt_list = Lwt_list -module MBytes = MBytes -module Uri = Uri -module Data_encoding = Data_encoding -module Time = Time -module Base48 = Base48 -module Hash = Hash module Ed25519 = struct type secret_key = Sodium.Sign.secret_key @@ -150,24 +126,60 @@ module Ed25519 = struct ~binary: (Fixed.bytes 64) end -module Persist = Persist -module Context = Context -module RPC = RPC -module Fitness = Fitness -module Updater = Updater -(* Internal usage *) +module Make(Param : sig val name: string end)() = struct -module Error_monad_sig = Error_monad_sig -module Error_monad = Error_monad -module Logging = Logging + include Pervasives + module Pervasives = Pervasives + module Compare = Compare + module Array = Array + module List = List + module Bytes = Bytes + module String = String + module Set = Set + module Map = Map + module Int32 = Int32 + module Int64 = Int64 + module Nativeint = Nativeint + module Buffer = Buffer + module Format = Format + module Hex_encode = Hex_encode + module Lwt_sequence = Lwt_sequence + module Lwt = Lwt + module Lwt_list = Lwt_list + module MBytes = MBytes + module Uri = Uri + module Data_encoding = Data_encoding + module Time = Time + module Ed25519 = Ed25519 + module Hash = Hash + module Persist = Persist + module RPC = RPC + module Fitness = Fitness + module Updater = Updater + module Error_monad = struct + type error_category = [ `Branch | `Temporary | `Permanent ] + include Error_monad.Make() + end + module Logging = Logging.Make(Param) + module Base48 = struct + include Base48 + include Make(struct type context = Context.t end) + end + module Context = struct + include Context + let register_resolver = Base48.register_resolver + let complete = Base48.complete + end + + module type PACKED_PROTOCOL = sig + val hash : Protocol_hash.t + include Updater.PROTOCOL + val error_encoding : error Data_encoding.t + val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] + val pp : Format.formatter -> error -> unit + val complete_b48prefix : + ?alphabet:string -> Context.t -> string -> string list Lwt.t + end -module type PACKED_PROTOCOL = sig - val hash : Protocol_hash.t - include Updater.PROTOCOL - val error_encoding : error Data_encoding.t - val classify_errors : error list -> [ `Branch | `Temporary | `Permanent ] - val pp : Format.formatter -> error -> unit - val complete_b48prefix : - ?alphabet:string -> Context.t -> string -> string list Lwt.t end diff --git a/src/node/updater/environment_gen.ml b/src/node/updater/environment_gen.ml index 7f578346b..99fab1063 100644 --- a/src/node/updater/environment_gen.ml +++ b/src/node/updater/environment_gen.ml @@ -21,6 +21,11 @@ let dump_file oc file = let included = ["Pervasives"] +let () = + Printf.fprintf mli + "module Make(Param : sig val name: string end)() : sig\n" + + let () = for i = 2 to Array.length Sys.argv - 1 do let file = Sys.argv.(i) in @@ -36,10 +41,12 @@ let () = dump_file mli file; Printf.fprintf mli "end\n"; if unit = "Result" then begin - Printf.fprintf mli "type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b\n"; + Printf.fprintf mli + "type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b\n"; end; done + let () = Printf.fprintf mli {| module type PACKED_PROTOCOL = sig @@ -55,4 +62,5 @@ val __cast: (module PACKED_PROTOCOL) -> (module Protocol.PACKED_PROTOCOL) |} let () = + Printf.fprintf mli "end\n" ; close_out mli diff --git a/src/node/updater/proto_environment.ml b/src/node/updater/proto_environment.ml index 05e795ef3..fc22e9a60 100644 --- a/src/node/updater/proto_environment.ml +++ b/src/node/updater/proto_environment.ml @@ -7,7 +7,11 @@ (* *) (**************************************************************************) -include Environment +module Make(Param : sig val name: string end)() = struct -let __cast (type error) (module X : PACKED_PROTOCOL) = - (module X : Protocol.PACKED_PROTOCOL) + include Environment.Make(Param)() + + let __cast (type error) (module X : PACKED_PROTOCOL) = + (module X : Protocol.PACKED_PROTOCOL) + +end diff --git a/src/node/updater/register.ml b/src/node/updater/register.ml index 9e1ee9242..dc13192be 100644 --- a/src/node/updater/register.ml +++ b/src/node/updater/register.ml @@ -29,8 +29,7 @@ module Make(Proto : Protocol.PACKED_PROTOCOL) = struct (function ecoerrors -> Ecoproto_error ecoerrors) end -let register proto = - let module Proto = (val Proto_environment.__cast proto) in +let register (module Proto : Protocol.PACKED_PROTOCOL) = let module V = struct include Proto include Make(Proto) diff --git a/src/node/updater/register.mli b/src/node/updater/register.mli index 4da480158..c24a4c108 100644 --- a/src/node/updater/register.mli +++ b/src/node/updater/register.mli @@ -12,4 +12,4 @@ module Make(Proto : Protocol.PACKED_PROTOCOL) : sig val wrap_error: 'a Proto.tzresult -> 'a tzresult end -val register: (module Proto_environment.PACKED_PROTOCOL) -> unit +val register: (module Protocol.PACKED_PROTOCOL) -> unit diff --git a/src/proto/bootstrap/.merlin b/src/proto/bootstrap/.merlin index 1d807e77f..bee23c94c 100644 --- a/src/proto/bootstrap/.merlin +++ b/src/proto/bootstrap/.merlin @@ -1,9 +1,9 @@ B ../../node/updater/ B _tzbuild FLG -nopervasives -FLG -open Proto_environment +FLG -open Local_environment +FLG -open Environment FLG -open Hash -FLG -open Local_modules FLG -open Error_monad FLG -open Logging FLG -w -40 diff --git a/src/proto/bootstrap/storage_functors.ml b/src/proto/bootstrap/storage_functors.ml index d95851b64..7c95b0327 100644 --- a/src/proto/bootstrap/storage_functors.ml +++ b/src/proto/bootstrap/storage_functors.ml @@ -376,6 +376,6 @@ let register_resolvers (module H : Hash.HASH) prefixes = Set.empty hs |> Set.elements in - Base48.register_resolver H.b48check_encoding resolve + Context.register_resolver H.b48check_encoding resolve diff --git a/src/proto/demo/.merlin b/src/proto/demo/.merlin index 1d807e77f..bee23c94c 100644 --- a/src/proto/demo/.merlin +++ b/src/proto/demo/.merlin @@ -1,9 +1,9 @@ B ../../node/updater/ B _tzbuild FLG -nopervasives -FLG -open Proto_environment +FLG -open Local_environment +FLG -open Environment FLG -open Hash -FLG -open Local_modules FLG -open Error_monad FLG -open Logging FLG -w -40 diff --git a/src/proto/environment/base48.mli b/src/proto/environment/base48.mli index dd000467b..ba3cc3733 100644 --- a/src/proto/environment/base48.mli +++ b/src/proto/environment/base48.mli @@ -3,12 +3,12 @@ module Prefix : sig val protocol_prefix: string end -type 'a encoding = 'a Base48.encoding +type 'a encoding val simple_decode: ?alphabet:string -> 'a encoding -> string -> 'a option val simple_encode: ?alphabet:string -> 'a encoding -> 'a -> string -type data = Base48.data = .. +type data = .. val register_encoding: prefix: string -> @@ -18,9 +18,3 @@ val register_encoding: 'a encoding val decode: ?alphabet:string -> string -> data option - -val register_resolver: - 'a encoding -> (Context.t -> string -> 'a list Lwt.t) -> unit - -val complete: - ?alphabet:string -> Context.t -> string -> string list Lwt.t diff --git a/src/proto/environment/context.mli b/src/proto/environment/context.mli index 3bf8d08d5..a2e895dcf 100644 --- a/src/proto/environment/context.mli +++ b/src/proto/environment/context.mli @@ -7,3 +7,9 @@ include Persist.STORE val get_genesis_time: t -> Time.t Lwt.t val get_genesis_block: t -> Block_hash.t Lwt.t + +val register_resolver: + 'a Base48.encoding -> (t -> string -> 'a list Lwt.t) -> unit + +val complete: + ?alphabet:string -> t -> string -> string list Lwt.t