[#1997] Update BuildSystem interface

lib/ligo_build_system/BuildSystem.ml

@@ -2,6 +2,8 @@ module PP = PP
 module Errors = Errors
 module To_yojson = To_yojson
 module Formatter = Formatter
+module Location = Simple_utils.Location
+module Ne_list = Simple_utils.Ne_list
 open Core
 include Types
 
@@ -19,208 +21,265 @@ module Source_input = struct
     }
 
   type code_input =
+    (* FIXME remove all non-needed code_input *)
     | From_file of file_name
     | HTTP of Uri.t
     | Raw of raw_input
     | Raw_input_lsp of raw_input_lsp
 
+  let map_code_input : code_input -> f:(file_name -> file_name) -> code_input =
+   fun code_input ~f ->
+    match code_input with
+    | From_file file_name -> From_file (f file_name)
+    | HTTP uri -> HTTP uri
+    | Raw { id; code } -> Raw { id = f id; code }
+    | Raw_input_lsp { file; code } -> Raw_input_lsp { file = f file; code }
+
   let id_of_code_input : code_input -> file_name = function
     | From_file file_name -> file_name
     | HTTP uri -> Filename.basename @@ Uri.to_string uri
     | Raw { id; code = _ } -> id
     | Raw_input_lsp { file; code = _ } -> file
 end
 
-module type M = sig
+module T = struct
   type file_name = Source_input.file_name
   type raw_input = Source_input.raw_input
   type code_input = Source_input.code_input
   type module_name = string
-  type imports = file_name list
-  type compilation_unit
+
+  (** `import` composes metadata of imported module
+      `location` is used for error reporting *)
+  type import =
+    { code_input : code_input
+    ; module_name : module_name
+    ; location : Location.t
+    }
+
+  type imports = import list
+end
+
+include T
+
+module type M = sig
+  (** Metadata of contract being built *)
   type meta_data
 
-  val preprocess
-    :  code_input
-    -> compilation_unit * meta_data * (file_name * module_name) list
+  (** Module representing compilation unit *)
+  module C_unit : sig
+    type t
+
+    (* Composes all data needed for compilation *)
+    type meta =
+      { code_input : code_input
+      ; location : Location.t
+      ; module_name : module_name
+      ; meta : meta_data
+      ; imports : imports
+      }
+  end
+
+  (** Converts import into ready to compile C_unit.t, gathers meta_data and imports *)
+  val preprocess : import -> C_unit.t * meta_data * imports
 
+  (** Module reprenting target AST which contract compiles to *)
   module AST : sig
+    (** Target AST type *)
     type t
 
-    (* An interface describes the signature of a module *)
+    (** An interface describes the signature of a module *)
     type interface
 
-    (* Environment should be a local notion of the BuildSystem *)
-    type environment
-
+    (** Links two asts into one *)
     val link : t -> t -> t
-    val link_interface : interface -> interface -> interface
-    val init_env : environment
 
-    val add_module_to_environment
-      :  file_name
-      -> module_name
-      -> imports
-      -> interface
-      -> environment
-      -> environment
+    (* This should probably be taken in charge be the compiler, which should be able to handle "libraries" *)
 
-    val add_interface_to_environment : interface -> environment -> environment
+    (** Adds inline module to the ast *)
+    val make_module_in_ast : t -> module_name * interface * t -> t
+  end
 
-    (* This should probably be taken in charge be the compiler, which should be able to handle "libraries" *)
-    val make_module_in_ast : module_name -> t -> t -> t
-    val make_module_in_interface : module_name -> interface -> interface -> interface
+  (** Module representing compilation environment *)
+  module Environment : sig
+    type t
+
+    val init_env : t
+    val add_interface : t -> AST.interface -> t
+    val find_interface : t -> module_name -> AST.interface
+    val add_module : t -> C_unit.meta -> AST.interface -> t
   end
 
-  val link_imports : AST.t -> intfs:AST.environment -> AST.t
+  (* Actually performs compilation *)
+  val compile : C_unit.t -> C_unit.meta -> Environment.t -> AST.t * AST.interface
 
-  val compile
-    :  AST.environment
-    -> file_name
-    -> meta_data
-    -> compilation_unit
-    -> AST.t * AST.interface
+  (* Returns compiled standard library *)
+  val std_lib : unit -> AST.t * AST.interface
 
-  val lib_ast : unit -> AST.t
-  val lib_interface : unit -> AST.interface
+  (** Applies left transformations required for resulting AST *)
+  val postprocess : AST.t -> intfs:Environment.t -> AST.t
 end
 
-module Make (M : M) = struct
-  type file_name = M.file_name
-  type code_input = M.code_input
-
-  type vertice =
-    M.file_name * M.meta_data * M.compilation_unit * (M.file_name * M.module_name) list
-
-  type graph = G.t * vertice SMap.t
-  type error = Errors.t
-  type ast = M.AST.t
-  type obj_env = ast SMap.t
-  type intf_env = M.AST.environment
-  type interface = M.AST.interface
-  type 'a build_error = ('a, error) result
-
-  let dependency_graph : code_input -> graph =
-   fun code_input ->
-    let rec dfs (acc : M.file_name) (dep_g, vertices) (code_input, mangled_name) =
-      let id = Source_input.id_of_code_input code_input in
-      if not @@ Map.mem vertices id
-      then (
-        let c_unit, meta_data, deps = M.preprocess code_input in
-        let vertices = Map.set vertices ~key:id ~data:(mangled_name, meta_data, c_unit, deps) in
-        let dep_g = G.add_vertex dep_g id in
-        let dep_g =
-          (* Don't add a loop on the first element *)
-          if Node.equal acc id then dep_g else G.add_edge dep_g acc id
-        in
-        let dep_g, vertices =
-          let f (x, y) =
-            let dependency_code_input = Source_input.From_file x in
-            dependency_code_input, y
+module type S = functor (M : M) -> sig
+  (** Vertex of dependency graph *)
+  type vertex = M.C_unit.t * M.C_unit.meta
+
+  val module_name_of_vertex : vertex -> module_name
+
+  (** Dependency graph *)
+  type graph = G.t * vertex SMap.t
+
+  type 'a build_result = ('a, Errors.t) Result.t
+
+  (** Builds dependency graph from code_input *)
+  val dependency_graph : code_input -> graph
+
+  (** Checks if graph is a DAG and returns topsorted list of files to compile *)
+  val solve_graph : graph -> module_name -> (module_name * vertex) Ne_list.t build_result
+
+  (** Builds input without linking all the code_input dependencies into one AST.
+      Useful for inspection, debugging and testing. *)
+  val build_unqualified : code_input -> M.AST.t build_result
+
+  (** Builds input and links all its dependencies into its ast *)
+  val build_qualified : code_input -> (M.AST.t * M.Environment.t) build_result
+end
+
+module Make : S =
+functor
+  (M : M)
+  ->
+  struct
+    include M
+
+    type vertex = C_unit.t * C_unit.meta
+
+    let module_name_of_vertex : vertex -> module_name = fun (_, meta) -> meta.module_name
+
+    type graph = G.t * vertex SMap.t
+    type 'a build_result = ('a, Errors.t) Result.t
+    type obj_map = AST.t SMap.t
+
+    let dependency_graph : code_input -> graph =
+     fun code_input ->
+      let rec dfs
+          (acc : module_name)
+          (dep_g, vertices)
+          ({ code_input; module_name; location } as import)
+        =
+        let id = Source_input.id_of_code_input code_input in
+        if not @@ Map.mem vertices id
+        then (
+          (* Historically, preprocess is used for extracting dependencies also *)
+          let c_unit, meta, imports = preprocess import in
+          let vertices =
+            Map.set
+              vertices
+              ~key:id
+              ~data:(c_unit, C_unit.{ code_input; location; module_name; meta; imports })
           in
-          let deps = List.map ~f deps in
-          List.fold ~f:(dfs id) ~init:(dep_g, vertices) deps
-        in
-        dep_g, vertices)
-      else (
-        let dep_g = G.add_edge dep_g acc id in
-        dep_g, vertices)
-    in
-    let vertices = SMap.empty in
-    let dep_g = G.empty in
-    let file_name = Source_input.id_of_code_input code_input in
-    dfs file_name (dep_g, vertices) @@ (code_input, file_name)
-
-  let solve_graph : graph -> file_name -> ((file_name * vertice) list, error) result =
-   fun (dep_g, vertices) file_name ->
-    if Dfs.has_cycle dep_g
-    then (
-      let graph = Format.asprintf "%a" PP.graph (dep_g, file_name) in
-      Error (Errors.build_dependency_cycle graph))
-    else (
-      let aux v order =
-        let elem = Map.find_exn vertices v in
-        (v, elem) :: order
-      in
-      let order = TopSort.fold aux dep_g [] in
-      Ok order)
-
-  let link ~(objs : obj_env) ~(intfs : intf_env) linking_order =
-    (* Separate the program and the dependency (those are process differently) *)
-    let (file_name, (_, _, _, _deps_lst)), linking_order =
-      match List.rev linking_order with
-      | [] -> failwith "compiling nothing"
-      | hd :: tl -> hd, tl
-    in
-    let contract =
-      match Map.find objs file_name with
-      | Some ast -> ast
-      | None -> failwith "failed to find module"
-    in
-    (* Add all dependency at the beginning of the file *)
-    let add_modules (file_name, (mangled_name, _, _, _deps_lst)) =
-      let module_binder = mangled_name in
-      (* Get the ast_type of the module *)
-      let ast_typed =
-        match Map.find objs file_name with
-        | Some ast -> ast
-        | None -> failwith "failed to find module"
-      in
-      module_binder, ast_typed
-    in
-    let header_list = List.map ~f:add_modules @@ linking_order in
-    let contract =
-      List.fold_left
-        ~f:(fun c (module_binder, ast) -> M.AST.make_module_in_ast module_binder ast c)
-        ~init:contract
-        header_list
-    in
-    (* Link the stdlib *)
-    let contract = M.AST.link (M.lib_ast ()) contract in
-    (* Finally link all the imports *)
-    let contract = M.link_imports contract ~intfs in
-    contract
-
-  let compile_file_with_deps
-      ((objs, intfs) : obj_env * intf_env)
-      (file_name, (mangled_name, meta, c_unit, _deps))
-    =
-    let imports = List.map ~f:(fun (x, _) -> x) _deps in
-    let ast, ast_intf = M.compile intfs file_name meta c_unit in
-    let intfs =
-      M.AST.add_module_to_environment file_name mangled_name imports ast_intf intfs
-    in
-    let objs = Map.set objs ~key:file_name ~data:ast in
-    objs, intfs
-
-  let compile_unqualified : code_input -> ast build_error =
-   fun main_code_input ->
-    let deps = dependency_graph main_code_input in
-    let main_file_name = Source_input.id_of_code_input main_code_input in
-    match solve_graph deps main_file_name with
-    | Ok ordered_deps ->
-      let init_env =
-        M.AST.add_interface_to_environment (M.lib_interface ()) M.AST.init_env
+          let dep_g = G.add_vertex dep_g id in
+          let dep_g =
+            (* Don't add a loop on the first element *)
+            if Node.equal acc id then dep_g else G.add_edge dep_g acc id
+          in
+          let dep_g, vertices = List.fold ~f:(dfs id) ~init:(dep_g, vertices) imports in
+          dep_g, vertices)
+        else (
+          let dep_g = G.add_edge dep_g acc id in
+          dep_g, vertices)
       in
-      let objs, _ =
-        List.fold ~f:compile_file_with_deps ~init:(SMap.empty, init_env) ordered_deps
+      let vertices = SMap.empty in
+      let dep_g = G.empty in
+      let file_name = Source_input.id_of_code_input code_input in
+      let module_name = file_name in
+      dfs file_name (dep_g, vertices)
+      @@ { code_input; module_name; location = Location.dummy }
+
+    let solve_graph : graph -> file_name -> (file_name * vertex) Ne_list.t build_result =
+     fun (dep_g, vertices) file_name ->
+      if Dfs.has_cycle dep_g
+      then (
+        let graph = Format.asprintf "%a" PP.graph (dep_g, file_name) in
+        Error (Errors.build_dependency_cycle graph))
+      else (
+        let aux v order =
+          let elem = Map.find_exn vertices v in
+          (v, elem) :: order
+        in
+        let order = TopSort.fold aux dep_g [] in
+        match order with
+        | hd :: tl -> Ok (hd :: tl)
+        | [] -> Error (Errors.build_compiling_nothing))
+
+    let link ~(objs : obj_map) ~(intfs : Environment.t) linking_order =
+      (* Separate the program and the dependency (those are process differently) *)
+      let (file_name, (_, C_unit.{ imports = _deps_lst; _ })), linking_order =
+        match Ne_list.rev linking_order with
+        | hd :: tl -> hd, tl
       in
-      Ok (Map.find_exn objs main_file_name)
-    | Error e -> Error e
-
-  let compile_qualified : code_input -> (ast * intf_env) build_error =
-   fun code_input ->
-    let deps = dependency_graph code_input in
-    let file_name = Source_input.id_of_code_input code_input in
-    match solve_graph deps file_name with
-    | Ok linking_order ->
-      let init_env =
-        M.AST.add_interface_to_environment (M.lib_interface ()) M.AST.init_env
+      (* NOTE The contract build system was invoked for must present in the build environment at this point *)
+      let contract = Map.find_exn objs file_name in
+      (* Add all dependency at the beginning of the file *)
+      let add_modules (file_name, (_, C_unit.{ module_name; imports = _deps_lst; _ })) =
+        let module_binder = module_name in
+        (* Get the ast_type of the module *)
+        (* NOTE Same for its deps: they were already compiled since we are at linking stage *)
+        let ast_typed = Map.find_exn objs file_name in
+        module_binder, ast_typed
       in
-      let objs, intfs =
-        List.fold ~f:compile_file_with_deps ~init:(SMap.empty, init_env) linking_order
+      let header_list = List.map ~f:add_modules @@ linking_order in
+      let contract =
+        List.fold_left
+          ~f:(fun c (module_binder, ast) ->
+            AST.make_module_in_ast
+              c
+              (module_binder, Environment.find_interface intfs module_binder, ast))
+          ~init:contract
+          header_list
       in
-      let contract = link ~objs ~intfs linking_order in
-      Ok (contract, intfs)
-    | Error e -> Error e
-end
+      (* Link the stdlib *)
+      let contract = AST.link (Tuple2.get1 @@ std_lib ()) contract in
+      (* Finally link all the imports *)
+      let contract = postprocess contract ~intfs in
+      contract
+
+    let compile_file_with_deps
+        ((objs, intfs) : obj_map * Environment.t)
+        (file_name, (c_unit, c_unit_meta))
+      =
+      let ast, ast_intf = compile c_unit c_unit_meta intfs in
+      let intfs = Environment.add_module intfs c_unit_meta ast_intf in
+      let objs = Map.set objs ~key:file_name ~data:ast in
+      objs, intfs
+
+    let build
+        :  code_input
+        -> (file_name * (file_name * vertex) Ne_list.t * obj_map * Environment.t) build_result
+      =
+     fun code_input ->
+      let deps = dependency_graph code_input in
+      let file_name = Source_input.id_of_code_input code_input in
+      match solve_graph deps file_name with
+      | Ok linking_order ->
+        let init_env = Environment.(add_interface init_env) (Tuple2.get2 @@ std_lib ()) in
+        let objs, intfs =
+          List.fold ~f:compile_file_with_deps ~init:(SMap.empty, init_env) @@ Ne_list.to_list linking_order
+        in
+        Ok (file_name, linking_order, objs, intfs)
+      | Error e -> Error e
+
+    let build_unqualified : code_input -> AST.t build_result =
+     fun code_input ->
+      let open Result.Monad_infix in
+      build code_input
+      >>= fun (module_name, _, objs, _) ->
+      (* NOTE The contract build system was invoked for must present in the build environment at this point *)
+      Ok (Map.find_exn objs module_name)
+
+    let build_qualified : code_input -> (AST.t * Environment.t) build_result =
+     fun code_input ->
+      let open Result.Monad_infix in
+      build code_input
+      >>= fun (_, linking_order, objs, intfs) ->
+      Ok (link ~objs ~intfs linking_order, intfs)
+  end

lib/ligo_build_system/errors.ml

@@ -4,9 +4,11 @@ module Ligo_Error = Simple_utils.Error
 type t =
   [ `Build_dependency_cycle of string
   | `Build_corner_case of string * string (* TO REMOVE *)
+  | `Build_compiling_nothing
   ]
 
 let build_dependency_cycle (s : string) = `Build_dependency_cycle s
+let build_compiling_nothing = `Build_compiling_nothing
 let build_corner_case (loc : string) (msg : string) = `Build_corner_case (loc, msg)
 
 let error_ppformat
@@ -19,6 +21,8 @@ let error_ppformat
     (match a with
     | `Build_dependency_cycle trace ->
       Format.fprintf f "@[<hv>Dependency cycle detected :@, %s@]" trace
+    | `Build_compiling_nothing ->
+      Format.fprintf f "@[<hv>Compiling nothing]"
     | `Build_corner_case (loc, msg) ->
       Format.fprintf f "@[<hv>Building corner case at %s : %s@]" loc msg)
 
@@ -30,6 +34,10 @@ let error_json : t -> Ligo_Error.t =
     let message = Format.asprintf "@[<hv>Dependency cycle detected :@, %s@]" trace in
     let content = Ligo_Error.make_content ~message () in
     Ligo_Error.make ~stage ~content
+  | `Build_compiling_nothing ->
+    let message = Format.asprintf "@[<hv>Compiling nothing]" in
+    let content = Ligo_Error.make_content ~message () in
+    Ligo_Error.make ~stage ~content
   | `Build_corner_case (loc, msg) ->
     let message = Format.asprintf "@[<hv>Building corner case at %s : %s@]" loc msg in
     let content = Ligo_Error.make_content ~message () in

vendored-dune/ligo-utils/simple-utils/Ne_list.ml

@@ -1,34 +1,44 @@
 open Core
 
-type 'a t = 'a Nonempty_list.t = (::) of 'a * 'a list [@@deriving eq, compare, yojson, hash, sexp, fold, map, iter, bin_io]
+type 'a t = 'a Nonempty_list.t = ( :: ) of 'a * 'a list
+[@@deriving eq, compare, yojson, hash, sexp, fold, map, iter, bin_io]
 
 let make x l = x :: l
-
-let sexp_of_t f Nonempty_list.(hd::tl) = List.sexp_of_t f (hd :: tl)
+let sexp_of_t f Nonempty_list.(hd :: tl) = List.sexp_of_t f (hd :: tl)
 
 let t_of_sexp f (x : Sexp.t) : 'a t =
   match x with
-  | Atom _ -> [f x]
-  | List (x::l) -> f x :: List.map ~f l
+  | Atom _ -> [ f x ]
+  | List (x :: l) -> f x :: List.map ~f l
   | List [] -> assert false
 
 let of_list_opt = function
   | [] -> None
   | x :: l -> Some Nonempty_list.(x :: l)
 
-let append Nonempty_list.(x::l) Nonempty_list.(x'::l') =
+let append Nonempty_list.(x :: l) Nonempty_list.(x' :: l') =
   Nonempty_list.(x :: List.(append l (x' :: l')))
 
 let collect : 'a option Nonempty_list.t -> 'a Nonempty_list.t option = function
   | None :: _ -> None
   | Some x :: l ->
-    match Option.all l with
+    (match Option.all l with
     | None -> None
-    | Some l -> Some (x :: l)
+    | Some l -> Some (x :: l))
 
 let rec fold_right1 ~f : 'a Nonempty_list.t -> 'a = function
-| [hd] -> hd
-| hd :: (x::l) -> f hd @@ fold_right1 ~f Nonempty_list.(x::l)
+  | [ hd ] -> hd
+  | hd :: x :: l -> f hd @@ fold_right1 ~f Nonempty_list.(x :: l)
+
+let rev : 'a Nonempty_list.t -> 'a Nonempty_list.t = function
+  | [ hd ] -> [ hd ]
+  | hd :: tl ->
+    (match List.rev (hd :: tl) with
+    | [] -> [ hd ]
+    | hd1 :: tl1 -> hd1 :: tl1)
+
+let to_list : 'a Nonempty_list.t -> 'a list = function
+  | hd :: tl -> hd :: tl
 
 type json = Yojson.Safe.t
 

vendored-dune/ligo-utils/simple-utils/Ne_list.mli

@@ -12,6 +12,10 @@ val collect : 'a option t -> 'a t option
 
 val fold_right1 : f:('a -> 'a -> 'a) -> 'a t -> 'a
 
+val rev : 'a t -> 'a t
+
+val to_list : 'a t -> 'a list
+
 type json = Yojson.Safe.t
 
 val yojson_of_t : ('a -> json) -> 'a t -> json