Compiler: use explicit functor in Environment

Previously, the functor applications were hidden in a module generated
by `tezos-protocol-compiler`.

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
 

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

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 environment_module = packname ^ ".Local_environment.Environment" in
-  let base48 = packname ^ ".Local_modules.Base48" 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_module
-       error_monad
+       error_monad_module
        packname (String.capitalize_ascii unit)
-       error_monad
+       error_monad_module
-       error_monad
+       error_monad_module
-       error_monad
+       error_monad_module
-       base48
+       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_environment_unit = "local_environment" in
-  let local_modules_ml = build_dir // local_modules_unit ^ ".ml" in
+  let local_environment_ml = build_dir // local_environment_unit ^ ".ml" in
-  create_file local_modules_ml @@ Printf.sprintf {|
+  create_file local_environment_ml @@ Printf.sprintf {|
-      module Error_monad = struct
+      module Environment = %s.Make(struct let name = %S end)()
-        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
     |}
+    (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_environment_ml) ;
-        safe_unlink local_modules_ml) ;
+  let local_environment_object =
-  let local_modules_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_environment"; "Environment" ;
-    [ "Local_modules"; "Error_monad" ; "Hash" ; "Logging" ];
+      "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;

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,19 +126,53 @@ 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
+  include Pervasives
-module Error_monad = Error_monad
+  module Pervasives = Pervasives
-module Logging = Logging
+  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
+  module type PACKED_PROTOCOL = sig
     val hash : Protocol_hash.t
     include Updater.PROTOCOL
     val error_encoding : error Data_encoding.t
@@ -170,4 +180,6 @@ module type PACKED_PROTOCOL = sig
     val pp : Format.formatter -> error -> unit
     val complete_b48prefix :
       ?alphabet:string -> Context.t -> string -> string list Lwt.t
+  end
+
 end

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

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) =
+  include Environment.Make(Param)()
+
+  let __cast (type error) (module X : PACKED_PROTOCOL) =
     (module X : Protocol.PACKED_PROTOCOL)
+
+end

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 register (module Proto : Protocol.PACKED_PROTOCOL) =
-  let module Proto = (val Proto_environment.__cast proto) in
   let module V = struct
     include Proto
     include Make(Proto)

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

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

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
 
 

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

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

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