First commit

.ocamlformat

@@ -0,0 +1,13 @@
+version=0.27.0
+exp-grouping=preserve
+break-infix=wrap-or-vertical
+break-collection-expressions=wrap
+break-sequences=false
+break-infix-before-func=false
+dock-collection-brackets=true
+break-separators=before
+field-space=tight
+if-then-else=compact
+break-sequences=false
+sequence-blank-line=compact
+exp-grouping=preserve

TODO.md

@@ -0,0 +1,6 @@
+- [ ] be able to load *.cmx{,a} when we use "#require"
+  `findlib`/`topfind` only loads directories, `ocamlnat` wants to load files.
+  Let's use our work about `uniq` to solve dependencies and load artifacts
+- [ ] do some tests with Miou and see if we can execute small applications
+- [ ] start to eval a file (and show the result?)
+- [ ] start to make a nice intf for a HTTP server via `httpcats`

bin/dune

@@ -0,0 +1,6 @@
+(executable
+ (name vif)
+ (public_name vif)
+ (flags
+  (:standard -w -18))
+ (libraries logs.fmt fmt.tty vif.top))

bin/vif.ml

@@ -0,0 +1,51 @@
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ = over (); k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("%a[%a]: " ^^ fmt ^^ "\n%!")
+        Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src)
+    in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
+  in
+  { Logs.report }
+
+let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
+let () = Logs.set_reporter (reporter Fmt.stdout)
+let () = Logs.set_level ~all:true (Some Logs.Debug)
+
+let main =
+  [
+    {ocaml|let v = 42;;|ocaml}
+  ; {ocaml|let rec infinity () = infinity ();;|ocaml}
+  ; {ocaml|print_endline "Hello World!";;|ocaml}
+  ; {ocaml|let a = Bool.to_int true;;|ocaml}
+  ; {ocaml|#show_dirs;;|ocaml}
+  ; {ocaml|#require "miou";;|ocaml}
+  ; {ocaml|let fn () = print_endline "Hello from Miou!";;|ocaml}
+  ; {ocaml|Miou.run fn;;|ocaml}
+  ]
+
+let stdlib = Fpath.v "/home/dinosaure/.opam/5.2.0+ocamlnat/lib/ocaml/"
+
+let run roots =
+  let cfg = Vif_top.config ~stdlib roots in
+  match Vif_top.eval cfg main with
+  | Ok sstr -> List.iter print_endline sstr
+  | Error sstr -> List.iter prerr_endline sstr
+
+open Cmdliner
+
+let term =
+  let open Term in
+  const run $ Vif_meta.setup
+
+let cmd =
+  let doc = "vif" in
+  let man = [] in
+  let info = Cmd.info "vif" ~doc ~man in
+  Cmd.v info term
+
+let () = Cmd.(exit @@ eval cmd)

dune-project

@@ -0,0 +1,2 @@
+(lang dune 3.0)
+(name vif)

lib/digest.ml

@@ -0,0 +1,17 @@
+include Stdlib.Digest
+
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+let pp ppf t = Fmt.string ppf (Stdlib.Digest.to_hex t)
+
+let of_string str =
+  match of_hex str with
+  | v -> Ok v
+  | exception Invalid_argument _ -> error_msgf "Invalid digest value: %S" str
+
+let length = String.length (string "")
+
+module Map = Map.Make (struct
+  type nonrec t = t
+
+  let compare = compare
+end)

lib/digest.mli

@@ -0,0 +1,7 @@
+include module type of Stdlib.Digest
+
+val pp : t Fmt.t
+val of_string : string -> (t, [> `Msg of string ]) result
+val length : int
+
+module Map : Map.S with type key = t

lib/dune

@@ -0,0 +1,27 @@
+(library
+ (name vif_top)
+ (modules vif_top)
+ (public_name vif.top)
+ (modes native)
+ (libraries
+  vif.meta
+  compiler-libs
+  compiler-libs.common
+  compiler-libs.native-toplevel))
+
+(ocamllex vif_meta_lexer)
+
+(library
+ (name vif_meta)
+ (modules vif_meta vif_meta_lexer objinfo digest modname unitname)
+ (public_name vif.meta)
+ (modes native)
+ (libraries
+  compiler-libs
+  compiler-libs.common
+  fmt
+  bos
+  logs
+  unix
+  fpath
+  cmdliner))

lib/modname.ml

@@ -0,0 +1,37 @@
+type t = string
+
+let msgf fmt = Format.kasprintf (fun msg -> `Msg msg) fmt
+
+let for_all f str =
+  let rec go acc idx =
+    if idx < String.length str then go (f str.[idx] && acc) (succ idx) else acc
+  in
+  go true 0
+
+let is_upper = function 'A' .. 'Z' -> true | _ -> false
+let is_lower = function 'a' .. 'z' -> true | _ -> false
+
+let is_valid_module_char = function
+  | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'' -> true
+  | '-' ->
+      true
+      (* XXX(dinosaure): an example exists: [First-class-modules].
+       [ocamlopt] can compile it but it emits an warning. *)
+  | _ -> false
+
+let of_string str =
+  if String.length str < 1 then Error (msgf "Invalid empty module name")
+  else if
+    (is_upper str.[0] || is_lower str.[0]) && for_all is_valid_module_char str
+  then Ok str
+  else Error (msgf "Invalid module name: %S" str)
+
+let v str =
+  match of_string str with Ok v -> v | Error (`Msg err) -> failwith err
+
+let pp ppf t = Format.pp_print_string ppf t
+let reflect ppf t = Fmt.pf ppf "(Modname.v %S)" t
+let to_string v = v
+let compare = String.compare
+
+module Map = Map.Make (String)

lib/modname.mli

@@ -0,0 +1,42 @@
+(** Module name.
+
+    the module name is a [string] that respects certain predicates. It is
+    impossible to have any other characters than:
+    - ['a' .. 'z']
+    - ['A' .. 'Z']
+    - ['0' .. '9']
+    - ['_'], ['-'] or ['\'']
+
+    {b NOTE}: The dash is accepted even if it is normally prohibited. You can
+    compile a module [my-module.ml]. However, the compiler issues a warning. In
+    order to be the least restrictive, we accept this character.
+
+    The module name must start with a letter.
+
+    {b NOTE}: The name of a {i module type} can start with a non-capital letter:
+
+    {[
+      module type foo = sig end
+    ]} *)
+
+type t
+(** The type of module names. *)
+
+val of_string : string -> (t, [> `Msg of string ]) result
+(** [of_string str] validates the given [str] as a module name or return an
+    error with an explanation. *)
+
+val v : string -> t
+(** [v str] calls {!val:of_string}. It raises an [Invalid_argument] instead of
+    returning an error. *)
+
+val pp : t Fmt.t
+(** Pretty printer of {!type:t}. *)
+
+val to_string : t -> string
+(** [to_string t] casts the given [t] as a [string]. *)
+
+val compare : t -> t -> int
+val reflect : t Fmt.t
+
+module Map : Map.S with type key = t

lib/objinfo.ml

@@ -0,0 +1,368 @@
+let src = Logs.Src.create "uniq.info"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+
+[@@@warning "-32"]
+
+let ( % ) f g x = f (g x)
+
+type t = {
+    name: Unitname.t
+  ; version: int option
+  ; exports: (Modname.t * Digest.t option) list
+  ; intfs: elt list
+  ; impls: elt list
+  ; format: format
+}
+
+and elt =
+  | Qualified of Modname.t * Digest.t
+  | Fully_qualified of Modname.t * Digest.t * Fpath.t
+  | Located of Modname.t * Fpath.t
+  | Named of Modname.t
+
+and 'a kind =
+  | Cmo : Cmo_format.compilation_unit kind
+  | Cma : Cmo_format.library kind
+  | Cmi : Cmi_format.cmi_infos kind
+  | Cmx : Cmx_format.unit_infos kind
+  | Cmxa : Cmx_format.library_infos kind
+
+and format = Format : 'a kind * 'a -> format
+
+let equal a b =
+  String.equal (Unitname.filepath a.name) (Unitname.filepath b.name)
+
+exception Inconsistency of Unitname.t * Modname.t * Digest.t * Digest.t
+
+let inconsistency location name crc crc' =
+  let unit = Unitname.modulize (Fpath.to_string location) in
+  raise (Inconsistency (unit, name, crc, crc'))
+
+let is_fully_resolved t =
+  List.for_all (function Fully_qualified _ -> true | _ -> false) t.intfs
+  && List.for_all (function Fully_qualified _ -> true | _ -> false) t.impls
+
+let is_a_library t =
+  match t.format with
+  | Format (Cma, _) -> true
+  | Format (Cmxa, _) -> true
+  | _ -> false
+
+let is_native t =
+  match t.format with
+  | Format (Cmx, _) -> true
+  | Format (Cmxa, _) -> true
+  | Format (Cmi, _) -> true
+  | _ -> false
+
+let is_an_interface t =
+  match t.format with Format (Cmi, _) -> true | _ -> false
+
+let is_a_cmi t = match t.format with Format (Cmi, _) -> true | _ -> false
+
+let of_elt = function
+  | Qualified (m, crc) -> (m, Some crc)
+  | Fully_qualified (m, crc, _) -> (m, Some crc)
+  | Located (m, _) -> (m, None)
+  | Named m -> (m, None)
+
+let exports t = t.exports
+let location t = Fpath.v (Unitname.filepath t.name)
+let intfs_imported t = List.map of_elt t.intfs
+let impls_imported t = List.map of_elt t.impls
+let modname t = Unitname.modname t.name
+
+let missing t =
+  let intfs, _ =
+    List.partition_map
+      (function
+        | Named m | Qualified (m, _) -> Either.Left m | _ -> Either.Right ())
+      t.intfs
+  in
+  let impls, _ =
+    List.partition_map
+      (function
+        | Named m | Qualified (m, _) -> Either.Left m | _ -> Either.Right ())
+      t.impls
+  in
+  (intfs, impls)
+
+let crc_of t m =
+  let ( >>| ) x f = Stdlib.Option.map f x in
+  List.find_opt (fun (m', _) -> Modname.compare m m' = 0) t.exports
+  >>| snd
+  |> Option.join
+
+let kind t =
+  match t.format with
+  | Format (Cmo, _) | Format (Cma, _) | Format (Cmx, _) | Format (Cmxa, _) ->
+      `Impl
+  | Format (Cmi, _) -> `Intf
+
+let elt_name = function
+  | Qualified (x, _) | Fully_qualified (x, _, _) | Named x | Located (x, _) -> x
+
+let elt_replace elt elts =
+  List.fold_left
+    (fun acc elt' ->
+      let a = elt_name elt in
+      let b = elt_name elt' in
+      if Modname.compare a b = 0 then elt :: acc else elt' :: acc)
+    [] elts
+  |> List.rev
+
+let qualify t ?location ?crc kind modname =
+  let elt =
+    match (location, crc) with
+    | None, Some crc -> Qualified (modname, crc)
+    | Some location, Some crc -> Fully_qualified (modname, crc, location)
+    | None, None -> Named modname
+    | Some location, None -> Located (modname, location)
+  in
+  match kind with
+  | `Intf -> { t with intfs= elt_replace elt t.intfs }
+  | `Impl -> { t with impls= elt_replace elt t.impls }
+
+let elt_compare a b =
+  let a = elt_name a in
+  let b = elt_name b in
+  Modname.compare a b
+
+let elt_find modname lst =
+  try
+    List.find
+      (fun elt ->
+        let modname' = elt_name elt in
+        Modname.compare modname modname' = 0)
+      lst
+    |> function
+    | Qualified (_, crc) -> [ (modname, Some crc) ]
+    | Fully_qualified (_, crc, _) -> [ (modname, Some crc) ]
+    | Named _ -> [ (modname, None) ]
+    | Located _ -> [ (modname, None) ]
+  with Not_found -> []
+
+open Bos
+open Rresult
+
+let to_elt (str, crc) =
+  match crc with
+  | Some crc -> Qualified (Modname.v str, crc)
+  | None -> Named (Modname.v str)
+
+let info_of_cmi ~location ~version _ic =
+  match Cmt_format.read (Fpath.to_string location) with
+  | None, _ -> error_msgf "Invalid cmi object: %a" Fpath.pp location
+  | Some cmi, _ ->
+      let intfs = cmi.Cmi_format.cmi_crcs in
+      let intfs = List.map to_elt intfs in
+      let intfs = List.sort elt_compare intfs in
+      let impls = [] in
+      let format = Format (Cmi, cmi) in
+      let name = Unitname.modulize (Fpath.to_string location) in
+      let exports = elt_find (Unitname.modname name) intfs in
+      Ok { name; version; exports; intfs; impls; format }
+  | exception _ -> error_msgf "Invalid cmi object: %a" Fpath.pp location
+
+let info_of_cmo ~location ~version ic =
+  let cu_pos = input_binary_int ic in
+  seek_in ic cu_pos;
+  let cu = (input_value ic : Cmo_format.compilation_unit) in
+  let intfs = List.map to_elt cu.cu_imports in
+  let intfs = List.sort elt_compare intfs in
+  let impls = [] in
+  let format = Format (Cmo, cu) in
+  let name = Unitname.modulize (Fpath.to_string location) in
+  let exports = [ (Unitname.modname name, None) ] in
+  Ok { name; version; exports; intfs; impls; format }
+
+let info_of_cmx ~location ~version ic =
+  let ui = (input_value ic : Cmx_format.unit_infos) in
+  let name = Unitname.modulize (Fpath.to_string location) in
+  let exports = [ (Unitname.modname name, Some (Digest.input ic)) ] in
+  let intfs = List.map to_elt ui.ui_imports_cmi in
+  let intfs = List.sort elt_compare intfs in
+  let impls = List.map to_elt ui.ui_imports_cmx in
+  let impls = List.sort elt_compare impls in
+  let format = Format (Cmx, ui) in
+  Ok { name; version; exports; intfs; impls; format }
+
+let to_elt (modname, crc) =
+  match crc with Some crc -> Qualified (modname, crc) | None -> Named modname
+
+let info_of_cma ~location ~version ic =
+  let toc_pos = input_binary_int ic in
+  seek_in ic toc_pos;
+  let toc = (input_value ic : Cmo_format.library) in
+  let importss =
+    List.map (fun { Cmo_format.cu_imports; _ } -> cu_imports) toc.lib_units
+  in
+  let fold m (str, crc) =
+    let name = Modname.v str in
+    match (Modname.Map.find_opt name m, crc) with
+    | None, _ -> Modname.Map.add name crc m
+    | Some None, _ | Some (Some _), None ->
+        Modname.Map.add name crc (Modname.Map.remove name m)
+    | Some (Some crc'), Some crc ->
+        if crc <> crc' then inconsistency location name crc crc';
+        m
+  in
+  let imports = List.concat importss in
+  let m = List.fold_left fold Modname.Map.empty imports in
+  let exports =
+    List.map
+      (fun { Cmo_format.cu_name= Compunit cu_name; _ } ->
+        (Modname.v cu_name, None))
+      toc.lib_units
+  in
+  let intfs = Modname.Map.bindings m in
+  let intfs = List.map to_elt intfs in
+  let impls = [] in
+  let format = Format (Cma, toc) in
+  let name = Unitname.modulize (Fpath.to_string location) in
+  Ok { name; version; exports; intfs; impls; format }
+
+let info_of_cmxa ~location ~version ic =
+  let li = (input_value ic : Cmx_format.library_infos) in
+  let importss_cmi =
+    List.map
+      (fun ({ Cmx_format.ui_imports_cmi; _ }, _crc) -> ui_imports_cmi)
+      li.lib_units
+  in
+  let importss_cmx =
+    List.map
+      (fun ({ Cmx_format.ui_imports_cmx; _ }, _crc) -> ui_imports_cmx)
+      li.lib_units
+  in
+  let fold m (str, crc) =
+    let name = Modname.v str in
+    match (Modname.Map.find_opt name m, crc) with
+    | None, _ -> Modname.Map.add name crc m
+    | Some None, _ | Some (Some _), None ->
+        Modname.Map.add name crc (Modname.Map.remove name m)
+    | Some (Some crc'), Some crc ->
+        if crc <> crc' then inconsistency location name crc crc';
+        m
+  in
+  let exports =
+    List.map
+      (fun ({ Cmx_format.ui_name; _ }, crc) -> (Modname.v ui_name, Some crc))
+      li.lib_units
+  in
+  let m = List.fold_left fold Modname.Map.empty (List.concat importss_cmi) in
+  let intfs = Modname.Map.bindings m in
+  let intfs = List.map to_elt intfs in
+  let m = List.fold_left fold Modname.Map.empty (List.concat importss_cmx) in
+  let impls = Modname.Map.bindings m in
+  let impls = List.map to_elt impls in
+  let format = Format (Cmxa, li) in
+  let name = Unitname.modulize (Fpath.to_string location) in
+  Ok { name; version; exports; intfs; impls; format }
+
+let is_intf location = Fpath.mem_ext [ ".mli" ] location
+
+let from_object location { Misc.Magic_number.kind; version } ic =
+  let version = Some version in
+  match kind with
+  | Misc.Magic_number.Cmi -> info_of_cmi ~location ~version ic
+  | Cmo -> info_of_cmo ~location ~version ic
+  | Cma -> info_of_cma ~location ~version ic
+  | Cmx _ -> info_of_cmx ~location ~version ic
+  | Cmxa _ -> info_of_cmxa ~location ~version ic
+  | _ -> error_msgf "Unexpected OCaml object: %a" Fpath.pp location
+
+let v location =
+  OS.File.with_ic location @@ fun ic () ->
+  match Misc.Magic_number.read_info ic with
+  | Ok info -> from_object location info ic
+  | Error _ -> error_msgf "Invalid object: %a" Fpath.pp location
+
+let pp ppf t = Fmt.string ppf (Unitname.filepath t.name)
+
+let v location =
+  match v location () |> R.join with
+  | value -> value
+  | exception Inconsistency (unit, name, crc, crc') ->
+      error_msgf
+        "Inconsistency between interfaces:\n\
+         The given library %s requires two times the interface %a with\n\
+         1) the digest %a\n\
+         2) and the digest %a\n"
+        (Unitname.filepath unit) Modname.pp name Digest.pp crc Digest.pp crc'
+
+let vs lst =
+  let ( let* ) = Result.bind in
+  let fn acc path =
+    match acc with
+    | Error _ as err -> err
+    | Ok acc ->
+        let* a = v path in
+        Ok (a :: acc)
+  in
+  List.fold_left fn (Ok []) lst
+
+let dummy = String.make Digest.length '-'
+
+let show_elt ppf = function
+  | Qualified (name, crc) ->
+      Fmt.pf ppf "\t%a\t%a\n%!"
+        Fmt.(styled `Bold Digest.pp)
+        crc
+        Fmt.(styled `Yellow Modname.pp)
+        name
+  | Fully_qualified (name, crc, location) ->
+      Fmt.pf ppf "\t%a\t%a (%a)\n%!"
+        Fmt.(styled `Bold Digest.pp)
+        crc
+        Fmt.(styled `Yellow Modname.pp)
+        name
+        Fmt.(styled `Green Fpath.pp)
+        location
+  | Named name ->
+      Fmt.pf ppf "\t%a\t%a\n%!"
+        Fmt.(styled `Bold string)
+        dummy
+        Fmt.(styled `Yellow Modname.pp)
+        name
+  | Located (name, location) ->
+      Fmt.pf ppf "\t%a\t%a (%a)\n%!"
+        Fmt.(styled `Bold string)
+        dummy
+        Fmt.(styled `Yellow Modname.pp)
+        name
+        Fmt.(styled `Green Fpath.pp)
+        location
+
+let show_export ppf (name, crc) =
+  match crc with
+  | None ->
+      Fmt.pf ppf "\t%a\t%a\n%!"
+        Fmt.(styled `Bold string)
+        dummy
+        Fmt.(styled `Yellow Modname.pp)
+        name
+  | Some crc ->
+      Fmt.pf ppf "\t%a\t%a\n%!"
+        Fmt.(styled `Bold Digest.pp)
+        crc
+        Fmt.(styled `Yellow Modname.pp)
+        name
+
+let show ppf t =
+  Fmt.pf ppf "File: %a\n%!"
+    Fmt.(styled `Green string)
+    (Unitname.filepath t.name);
+  Fmt.pf ppf "Name: %a\n%!"
+    Fmt.(styled `Yellow Modname.pp)
+    (Unitname.modname t.name);
+  if Stdlib.Option.is_some t.version then
+    Fmt.pf ppf "Version: %d\n%!" (Stdlib.Option.get t.version);
+  if t.intfs <> [] then Fmt.pf ppf "Interfaces imported:\n%!";
+  List.iter (Fmt.pf ppf "%a" show_elt) t.intfs;
+  if t.impls <> [] then Fmt.pf ppf "Implementations imported:\n%!";
+  List.iter (Fmt.pf ppf "%a" show_elt) t.impls;
+  Fmt.pf ppf "Export:\n%!";
+  List.iter (Fmt.pf ppf "%a" show_export) t.exports

lib/unitname.ml

@@ -0,0 +1,48 @@
+type t = { modname: Modname.t; filepath: string }
+(* TODO(dinosaure): we probably should validate [filename] too as regular
+   file path. *)
+
+let invalid_arg fmt = Format.kasprintf invalid_arg fmt
+let is_upper = function 'A' .. 'Z' -> true | _ -> false
+let is_lower = function 'a' .. 'z' -> true | _ -> false
+
+let modulize filepath =
+  let filename = Filename.basename filepath in
+  let name = Filename.remove_extension filename in
+  if String.length name < 1 then
+    invalid_arg "Impossible to modulize an empty string";
+  if not (is_upper name.[0] || is_lower name.[0]) then
+    invalid_arg "Impossible to modulize %S (from %S)" name filename;
+  let modname = String.capitalize_ascii name in
+  let modname = Modname.v modname in
+  { modname; filepath }
+
+let pp ppf { modname; filepath } =
+  Fmt.pf ppf "%a(%s)" Modname.pp modname filepath
+
+let pp_as_modname ppf { modname; _ } = Modname.pp ppf modname
+let pp_as_filepath ppf { filepath; _ } = Format.pp_print_string ppf filepath
+let reflect ppf t = Fmt.pf ppf "(Unitname.modulize %S)" t.filepath
+let modname { modname; _ } = modname
+let filename { filepath; _ } = Filename.basename filepath
+let filepath { filepath; _ } = filepath
+let compare_as_modnames a b = Modname.compare a.modname b.modname
+
+let change_file_extension f t =
+  match Filename.extension t.filepath with
+  | "" -> t
+  | ext ->
+      let filepath = Filename.remove_extension t.filepath ^ "." ^ f ext in
+      { t with filepath }
+
+module Map = Map.Make (struct
+  type nonrec t = t
+
+  let compare a b = Modname.compare a.modname b.modname
+end)
+
+module Set = Set.Make (struct
+  type nonrec t = t
+
+  let compare a b = Modname.compare a.modname b.modname
+end)

lib/unitname.mli

@@ -0,0 +1,74 @@
+(** The Unit name is the name of a module which can be represented by a file.
+    The unit name {b transforms} the given file path into a {!type:Modname.t}
+    and keep the file path internally.
+
+    By this way, an {!t} as two views:
+    - as a file path (where the module is located into the file-system)
+    - as a module name *)
+
+type t
+(** Type of an unit name. *)
+
+val modulize : string -> t
+(** [modulize filename] makes a new {!type:t} which contains the given
+    [filename] and {i modulize} it: it removes the extension (if it exists), it
+    capitalises the first letter of the [filename]'s {!val:Filename.basename}
+    and replace any wrong characters by ['_'].
+
+    For instance:
+    - ["foo.ml"] => ["Foo"]
+    - ["Foo"] => ["Foo"]
+    - ["foo'.ml"] => ["Foo_"]
+    - ["lib/foo.ml"] => ["Foo"]
+    - ["foo-bar.ml"] => ["Foo-bar"]
+
+    We assert that:
+    {[
+      # let v = Unitname.modulize "foo.ml" ;;
+      # assert (Stdlib.compare v Unitname.(modulize (filepath v)) = 0) ;;
+    ]} *)
+
+val modname : t -> Modname.t
+
+val filename : t -> string
+(** [filename v] returns the {b filename} of the given unit name. The filename
+    is the {!val:Filename.basename} of the [filepath] given to construct [v]
+    with {!val:modulize}. *)
+
+val filepath : t -> string
+(** [filepath v] returns the {b filepath} of the given unit name. The file path
+    is the one used to construct [v] with {!val:modulize}. *)
+
+val pp : t Fmt.t
+val pp_as_modname : t Fmt.t
+val pp_as_filepath : t Fmt.t
+val reflect : t Fmt.t
+
+val compare_as_modnames : t -> t -> int
+(** [compare_as_modnames a b] compares [a] and [b] from their modname's views.
+    For instance,
+
+    {[
+      # let a = Unitname.modulize "foo/a.ml" ;;
+      # let b = Unitname.modulize "bar/a.ml" ;;
+      # Unitname.compare_as_modnames a b ;;
+      - : int = 0
+    ]} *)
+
+val change_file_extension : (string -> string) -> t -> t
+(** [change_file_extension f t] tries to replace the current extension of the
+    given [t] (the {i filename} view) by something else returned by [f]. If [t]
+    has no extension, we return it unchanged. Otherwise, we call [f] and give to
+    it the current extension.
+
+    {b NOTE}: The {i modname} view is {b unchanged} in any cases:
+    {[
+      # let v0 = Unitname.modulize "foo.ml" ;;
+      # let v1 = Unitname.change_file_extension (fun _ -> "mli") v0 ;;
+      # assert (Modname.compare (Unitname.modname v0) (Unitname.modname v1) = 0) ;;
+    ]}
+
+    However, [v0] and [v1] are not equal anymore. *)
+
+module Map : Map.S with type key = t
+module Set : Set.S with type elt = t

lib/vif_meta.ml

@@ -0,0 +1,399 @@
+let src = Logs.Src.create "uniq.meta"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+
+type t =
+  | Node of { name: string; value: string; contents: t list }
+    (* [name] "[value]" ( [contents] ),
+       like [package "lib" ( ... )] *)
+  | Set of { name: string; predicates: predicate list; value: string }
+    (* [name] [(...) as predicates] = [value],
+       like [archive(native) = "lib.cmxa"]*)
+  | Add of { name: string; predicates: predicate list; value: string }
+(* [name] [(...) as predicates] = [value],
+   like [archive(native) += "lib.cmxa"]*)
+
+and predicate = Include of string | Exclude of string
+
+let pp_predicate ppf = function
+  | Include p -> Fmt.string ppf p
+  | Exclude p -> Fmt.pf ppf "-%s" p
+
+let rec pp ppf = function
+  | Node { name; value; contents } ->
+      Fmt.pf ppf "%s %S (@\n@[<2>%a@]@\n)" name value
+        Fmt.(list ~sep:(any "@\n") pp)
+        contents
+  | Set { name; predicates= []; value } -> Fmt.pf ppf "%s = %S" name value
+  | Set { name; predicates; value } ->
+      Fmt.pf ppf "%s(%a) = %S" name
+        Fmt.(list ~sep:(any ",") pp_predicate)
+        predicates value
+  | Add { name; predicates= []; value } -> Fmt.pf ppf "%s += %S" name value
+  | Add { name; predicates; value } ->
+      Fmt.pf ppf "%s(%a) += %S" name
+        Fmt.(list ~sep:(any ",") pp_predicate)
+        predicates value
+
+module Assoc = struct
+  type t = (string * string list) list
+
+  let add k v t =
+    match List.assoc_opt k t with
+    | Some vs ->
+        let vs = List.sort_uniq String.compare (v :: vs) in
+        (k, vs) :: List.remove_assoc k t
+    | None -> (k, [ v ]) :: t
+
+  let set k v t =
+    match List.assoc_opt k t with
+    | Some _ -> (k, [ v ]) :: List.remove_assoc k t
+    | None -> (k, [ v ]) :: t
+end
+
+module Path = struct
+  type t = string list
+
+  let of_string str =
+    let pkg = String.split_on_char '.' str in
+    let rec go = function
+      | [] -> Ok pkg
+      | "" :: _ -> error_msgf "Invalid package name: %S" str
+      | _ :: rest -> go rest
+    in
+    go pkg
+
+  let of_string_exn str =
+    match of_string str with
+    | Ok pkg -> pkg
+    | Error (`Msg msg) -> invalid_arg msg
+
+  let pp ppf pkg = Fmt.string ppf (String.concat "." pkg)
+  let equal a b = try List.for_all2 String.equal a b with _ -> false
+end
+
+let compile ~predicates t ks =
+  let incl ps =
+    let one = function
+      | Include p -> List.exists (String.equal p) predicates
+      | Exclude p -> not (List.exists (String.equal p) predicates)
+    in
+    List.exists one ps
+  in
+  let rec go acc t = function
+    | [] ->
+        let rec go acc = function
+          | [] -> acc
+          | Node _ :: rest -> go acc rest
+          | Add { name; predicates= []; value } :: rest ->
+              go (Assoc.add name value acc) rest
+          | Set { name; predicates= []; value } :: rest ->
+              go (Assoc.set name value acc) rest
+          | Add { name; predicates; value } :: rest ->
+              if incl predicates then go (Assoc.add name value acc) rest
+              else go acc rest
+          | Set { name; predicates; value } :: rest ->
+              if incl predicates then go (Assoc.set name value acc) rest
+              else go acc rest
+        in
+        go acc t
+    | k :: ks -> (
+        match t with
+        | [] -> acc
+        | Node { name= "package"; value; contents } :: rest ->
+            if k = value then go acc contents ks else go acc rest (k :: ks)
+        | _ :: rest -> go acc rest (k :: ks))
+  in
+  go [] t ks
+
+exception Parser_error of string
+
+let raise_parser_error lexbuf fmt =
+  let p = Lexing.lexeme_start_p lexbuf in
+  let c = p.Lexing.pos_cnum - p.Lexing.pos_bol + 1 in
+  Fmt.kstr
+    (fun msg -> raise (Parser_error msg))
+    ("%s (l.%d c.%d): " ^^ fmt)
+    p.Lexing.pos_fname p.Lexing.pos_lnum c
+
+let pp_token ppf = function
+  | Vif_meta_lexer.Name name -> Fmt.string ppf name
+  | String str -> Fmt.pf ppf "%S" str
+  | Minus -> Fmt.string ppf "-"
+  | Lparen -> Fmt.string ppf "("
+  | Rparen -> Fmt.string ppf ")"
+  | Comma -> Fmt.string ppf ","
+  | Equal -> Fmt.string ppf "="
+  | Plus_equal -> Fmt.string ppf "+="
+  | Eof -> Fmt.string ppf "#eof"
+
+let invalid_token lexbuf token =
+  raise_parser_error lexbuf "Invalid token %a" pp_token token
+
+let lparen lexbuf =
+  match Vif_meta_lexer.token lexbuf with
+  | Lparen -> ()
+  | token -> invalid_token lexbuf token
+
+let name lexbuf =
+  match Vif_meta_lexer.token lexbuf with
+  | Name name -> name
+  | token -> invalid_token lexbuf token
+
+let string lexbuf =
+  match Vif_meta_lexer.token lexbuf with
+  | String str -> str
+  | token -> invalid_token lexbuf token
+
+let rec predicates lexbuf acc =
+  match Vif_meta_lexer.token lexbuf with
+  | Rparen -> List.rev acc
+  | Name predicate -> begin
+      match Vif_meta_lexer.token lexbuf with
+      | Comma -> predicates lexbuf (Include predicate :: acc)
+      | Rparen -> List.rev (Include predicate :: acc)
+      | token -> invalid_token lexbuf token
+    end
+  | Minus ->
+      let predicate = name lexbuf in
+      begin
+        match Vif_meta_lexer.token lexbuf with
+        | Comma -> predicates lexbuf (Exclude predicate :: acc)
+        | Rparen -> List.rev (Exclude predicate :: acc)
+        | token -> invalid_token lexbuf token
+      end
+  | token -> invalid_token lexbuf token
+
+let rec parser lexbuf depth acc =
+  match Vif_meta_lexer.token lexbuf with
+  | Rparen when depth > 0 -> List.rev acc
+  | Rparen ->
+      raise_parser_error lexbuf
+        "Closing parenthesis without matching opening one"
+  | Eof when depth = 0 -> List.rev acc
+  | Eof -> raise_parser_error lexbuf "%d closing parenthesis missing" depth
+  | Name name -> begin
+      match Vif_meta_lexer.token lexbuf with
+      | String value ->
+          lparen lexbuf;
+          let contents = parser lexbuf (succ depth) [] in
+          parser lexbuf depth (Node { name; value; contents } :: acc)
+      | Equal ->
+          let value = string lexbuf in
+          parser lexbuf depth (Set { name; predicates= []; value } :: acc)
+      | Plus_equal ->
+          let value = string lexbuf in
+          parser lexbuf depth (Add { name; predicates= []; value } :: acc)
+      | Lparen ->
+          let predicates = predicates lexbuf [] in
+          begin
+            match Vif_meta_lexer.token lexbuf with
+            | Equal ->
+                let value = string lexbuf in
+                parser lexbuf depth (Set { name; predicates; value } :: acc)
+            | Plus_equal ->
+                let value = string lexbuf in
+                parser lexbuf depth (Add { name; predicates; value } :: acc)
+            | token -> invalid_token lexbuf token
+          end
+      | token -> invalid_token lexbuf token
+    end
+  | token -> invalid_token lexbuf token
+
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+
+let parser lexbuf =
+  try Ok (parser lexbuf 0 []) with
+  | Parser_error err -> Error (`Msg err)
+  | Vif_meta_lexer.Lexical_error (msg, f, l, c) ->
+      error_msgf "%s at l.%d, c.%d: %s" f l c msg
+
+let parser path =
+  Log.debug (fun m -> m "Parse %a" Fpath.pp path);
+  let ( let@ ) finally fn = Fun.protect ~finally fn in
+  let ic = open_in (Fpath.to_string path) in
+  let@ _ = fun () -> close_in ic in
+  let lexbuf = Lexing.from_channel ic in
+  Lexing.set_filename lexbuf (Fpath.to_string path);
+  parser lexbuf
+
+let rec incl us vs =
+  match (us, vs) with
+  | u :: us, v :: vs -> if u = v then incl us vs else false
+  | [], _ | _, [] -> true
+
+let rec diff us vs =
+  match (us, vs) with
+  | u :: us, v :: vs ->
+      if u = v then diff us vs else error_msgf "Different paths (%S <> %S)" u v
+  | [], x | x, [] -> Ok x
+
+let relativize ~roots path =
+  let rec go = function
+    | [] -> assert false
+    | root :: roots ->
+        if Fpath.is_prefix root path then
+          match Fpath.relativize ~root path with
+          | Some rel -> (root, rel)
+          | None -> go roots
+        else go roots
+  in
+  go roots
+
+let search ~roots ?(predicates = [ "native"; "byte" ]) meta_path =
+  let ( >>= ) = Result.bind in
+  let ( >>| ) x f = Result.map f x in
+  let elements path =
+    if Sys.is_directory (Fpath.to_string path) then Ok false
+    else if Fpath.basename path = "META" then Ok true
+    else Ok false
+  in
+  let traverse path =
+    if List.exists (Fpath.equal path) roots then Ok true
+    else begin
+      let _, rel = relativize ~roots path in
+      let meta_path' = Fpath.segs rel in
+      Ok (incl meta_path meta_path')
+    end
+  in
+  let fold path acc =
+    let root, rel = relativize ~roots path in
+    let package = Fpath.(rem_empty_seg (parent rel)) in
+    let meta_path' = Fpath.(segs package) in
+    match
+      diff meta_path meta_path' >>= fun ks ->
+      parser path >>| fun meta -> compile ~predicates meta ks
+    with
+    | Ok descr -> Fpath.Map.add Fpath.(root // parent rel) descr acc
+    | Error (`Msg msg) ->
+        Log.warn (fun m ->
+            m "Impossible to extract the META file of %a: %s" Fpath.pp path msg);
+        acc
+  in
+  let err _path _ = Ok () in
+  Bos.OS.Path.fold ~err ~dotfiles:false ~elements:(`Sat elements)
+    ~traverse:(`Sat traverse) fold Fpath.Map.empty roots
+  >>| Fpath.Map.bindings
+
+let dependencies_of (_path, descr) =
+  Stdlib.Option.value ~default:[] (List.assoc_opt "requires" descr)
+  |> List.map (Astring.String.cuts ~empty:false ~sep:" ")
+  |> List.concat
+  |> List.map Path.of_string_exn
+
+exception Cycle
+
+let equal_dep meta_path (meta_path', _, _) = Path.equal meta_path meta_path'
+
+let sort libs =
+  let rec go acc later todo progress =
+    match (todo, later) with
+    | [], [] -> List.rev acc
+    | [], _ -> if progress then go acc [] later false else raise Cycle
+    | ((_, path, descr) as x) :: r, _ ->
+        let deps = dependencies_of (path, descr) in
+        let deps_already_added =
+          let fn dep = List.exists (equal_dep dep) acc in
+          List.for_all fn deps
+        in
+        if deps_already_added then go (x :: acc) later r true
+        else go acc (x :: later) r progress
+  in
+  let starts, todo =
+    List.partition
+      (fun (_, path, descr) -> dependencies_of (path, descr) = [])
+      libs
+  in
+  go starts [] todo false
+
+let ancestors ~roots ?(predicates = [ "native"; "byte" ]) meta_path =
+  let rec go acc visited = function
+    | [] -> Ok acc
+    | meta_path :: todo when List.mem meta_path visited -> go acc visited todo
+    | meta_path :: todo -> (
+        Log.debug (fun m -> m "search %a" Path.pp meta_path);
+        match search ~roots ~predicates meta_path with
+        | Ok pkgs ->
+            let requires = List.concat (List.map dependencies_of pkgs) in
+            Log.debug (fun m ->
+                m "search @[<hov>%a@]" Fmt.(Dump.list Path.pp) requires);
+            let pkgs =
+              List.map (fun (path, descr) -> (meta_path, path, descr)) pkgs
+            in
+            go (List.rev_append pkgs acc) (meta_path :: visited)
+              (List.rev_append requires todo)
+        | Error _ as err -> err)
+  in
+  let open Rresult in
+  go [] [] [ meta_path ] >>| sort
+
+let to_artifacts pkgs =
+  let ( let* ) = Result.bind in
+  let fn acc (path, pkg) =
+    match acc with
+    | Error _ as err -> err
+    | Ok acc ->
+        let directory = List.assoc_opt "directory" pkg in
+        let* directory =
+          match directory with
+          | Some [ dir ] -> Ok Fpath.(path / dir)
+          | Some _ ->
+              error_msgf "Multiple directories referenced by %a" Fpath.pp
+                Fpath.(path / "META")
+          | None -> Ok path
+        in
+        let directory = Fpath.to_dir_path directory in
+        let archive = List.assoc_opt "archive" pkg in
+        let archive = Stdlib.Option.value ~default:[] archive in
+        let plugin = List.assoc_opt "plugin" pkg in
+        let plugin = Stdlib.Option.value ~default:[] plugin in
+        let archive = List.map (Fpath.add_seg directory) archive in
+        let plugin = List.map (Fpath.add_seg directory) plugin in
+        Ok List.(rev_append archive (rev_append plugin acc))
+  in
+  let* paths = List.fold_left fn (Ok []) pkgs in
+  Objinfo.vs paths
+
+open Cmdliner
+
+let directories =
+  let doc = "The source directory containing the META files." in
+  let parser str =
+    match Fpath.of_string str with
+    | Ok _ as v when Sys.file_exists str && Sys.is_directory str -> v
+    | Ok v -> error_msgf "%a is not a directory or does not exist" Fpath.pp v
+    | Error _ as err -> err
+  in
+  let open Arg in
+  value
+  & opt_all (conv (parser, Fpath.pp)) []
+  & info [ "I" ] ~doc ~docv:"DIRECTORY"
+
+let setup user's_directories =
+  let cmd = Bos.Cmd.(v "ocamlfind" % "printconf" % "path") in
+  let ( let* ) = Result.bind in
+  let directories =
+    let* exists = Bos.OS.Cmd.exists cmd in
+    if exists then
+      let r = Bos.OS.Cmd.run_out cmd in
+      let* directories, _ = Bos.OS.Cmd.out_lines ~trim:true r in
+      let directories =
+        List.fold_left
+          (fun acc path ->
+            match Fpath.of_string path with
+            | Ok path -> path :: acc
+            | Error (`Msg _) ->
+                Logs.warn (fun m ->
+                    m "ocamlfind returned an invalid path: %S" path);
+                acc)
+          [] directories
+      in
+      Ok directories
+    else Ok []
+  in
+  let directories = Result.value ~default:[] directories in
+  List.rev_append directories user's_directories
+
+let setup = Term.(const setup $ directories)

lib/vif_meta.mli

@@ -0,0 +1,33 @@
+module Assoc : sig
+  type t = (string * string list) list
+end
+
+module Path : sig
+  type t = private string list
+
+  val of_string : string -> (t, [> `Msg of string ]) result
+  val of_string_exn : string -> t
+  val pp : t Fmt.t
+end
+
+type t
+
+val pp : t Fmt.t
+val parser : Fpath.t -> (t list, [> `Msg of string ]) result
+
+val search :
+     roots:Fpath.t list
+  -> ?predicates:string list
+  -> Path.t
+  -> ((Fpath.t * Assoc.t) list, [> `Msg of string ]) result
+
+val ancestors :
+     roots:Fpath.t list
+  -> ?predicates:string list
+  -> Path.t
+  -> ((Path.t * Fpath.t * Assoc.t) list, [> `Msg of string ]) result
+
+val to_artifacts :
+  (Fpath.t * Assoc.t) list -> (Objinfo.t list, [> `Msg of string ]) result
+
+val setup : Fpath.t list Cmdliner.Term.t

lib/vif_meta_lexer.mll

@@ -0,0 +1,80 @@
+(* The MIT License
+
+   Copyright (c) 2016 Jane Street Group, LLC <opensource@janestreet.com>
+   Copyright (c) 2024 Romain Calascibetta <romain.calascibetta@gmail.com>
+   
+   Permission is hereby granted, free of charge, to any person obtaining a copy
+   of this software and associated documentation files (the "Software"), to deal
+   in the Software without restriction, including without limitation the rights
+   to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+   copies of the Software, and to permit persons to whom the Software is
+   furnished to do so, subject to the following conditions:
+   
+   The above copyright notice and this permission notice shall be included in all
+   copies or substantial portions of the Software.
+   
+   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+   SOFTWARE. *)
+
+{
+exception Lexical_error of string * string * int * int
+
+type token =
+  | Name   of string
+  | String of string
+  | Minus
+  | Lparen
+  | Rparen
+  | Comma
+  | Equal
+  | Plus_equal
+  | Eof
+
+let escaped_buf = Buffer.create 256
+let raise_lexical_error lexbuf fmt =
+  let p = Lexing.lexeme_start_p lexbuf in
+  Fmt.kstr (fun msg ->
+    raise (Lexical_error (msg, p.Lexing.pos_fname,
+                               p.Lexing.pos_lnum,
+                               p.Lexing.pos_cnum - p.Lexing.pos_bol + 1)))
+    fmt
+}
+
+rule token = parse
+  | [' ' '\t' '\r']* { token lexbuf }
+  | '#' [^ '\n']* { token lexbuf }
+  | '\n' { Lexing.new_line lexbuf; token lexbuf }
+
+  | ['A'-'Z' 'a'-'z' '0'-'9' '_' '.']+ as s { Name s }
+  | '"'
+      { Buffer.clear escaped_buf;
+        string escaped_buf lexbuf }
+  | '-' { Minus }
+  | '(' { Lparen }
+  | ')' { Rparen }
+  | ',' { Comma }
+  | '=' { Equal }
+  | "+=" { Plus_equal }
+  | eof { Eof }
+  | _
+    { raise_lexical_error lexbuf "illegal character %S"
+        (String.escaped (Lexing.lexeme lexbuf)) }
+
+and string buf = parse
+  | '"'
+      { String (Buffer.contents buf) }
+  | "\\\n"
+  | '\n'
+      { Lexing.new_line lexbuf;
+        Buffer.add_char buf '\n';
+        string buf lexbuf }
+  | '\\' (_ as c)
+  | (_ as c)
+      { Buffer.add_char buf c;
+        string buf lexbuf }
+  | eof { raise_lexical_error lexbuf "unterminated string" }

lib/vif_top.ml

@@ -0,0 +1,327 @@
+let src = Logs.Src.create "vif.top"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type cfg = {
+    stdlib: Fpath.t
+  ; roots: Fpath.t list
+}
+
+let errors = ref false
+
+module Lexbuf = struct
+  open Lexing
+
+  let toplevel_fname = "//vif//"
+
+  let shift_toplevel_position ~start pos =
+    {
+      pos_fname= toplevel_fname
+    ; pos_lnum= pos.pos_lnum - start.pos_lnum + 1
+    ; pos_bol= pos.pos_bol - start.pos_cnum - 1
+    ; pos_cnum= pos.pos_cnum - start.pos_cnum
+    }
+
+  let shift_toplevel_location ~start loc =
+    let open Location in
+    {
+      loc with
+      loc_start= shift_toplevel_position ~start loc.loc_start
+    ; loc_end= shift_toplevel_position ~start loc.loc_end
+    }
+
+  let semisemi_action =
+    let lexbuf = Lexing.from_string ";;" in
+    match Lexer.token lexbuf with
+    | Parser.SEMISEMI -> lexbuf.Lexing.lex_last_action
+    | _ -> assert false
+
+  let map_error_loc ~fn (error : Location.error) =
+    let fn_msg (msg : Location.msg) = { msg with loc= fn msg.loc } in
+    { error with main= fn_msg error.main; sub= List.map fn_msg error.sub }
+
+  let shift_location_error start =
+    map_error_loc ~fn:(shift_toplevel_location ~start)
+
+  let position_mapper start =
+    let open Ast_mapper in
+    let start = { start with pos_fname= toplevel_fname } in
+    let location mapper loc =
+      shift_toplevel_location ~start (default_mapper.location mapper loc)
+    in
+    { default_mapper with location }
+end
+
+module Phrase = struct
+  open Lexing
+  open Parsetree
+
+  type t = {
+      startpos: position
+    ; parsed: (Parsetree.toplevel_phrase, exn) result
+  }
+
+  let result t = t.parsed
+  let start t = t.startpos
+
+  let error_of_exn exn =
+    match Location.error_of_exn exn with
+    | None -> None
+    | Some `Already_displayed -> None
+    | Some (`Ok error) -> Some error
+
+  let parse lines =
+    let contents = String.concat "\n" lines in
+    let lexbuf = Lexing.from_string contents in
+    let startpos = lexbuf.Lexing.lex_start_p in
+    let parsed =
+      match !Toploop.parse_toplevel_phrase lexbuf with
+      | phrase -> Ok phrase
+      | exception exn ->
+          let exn =
+            match error_of_exn exn with
+            | None -> raise exn
+            | Some error ->
+                Location.Error (Lexbuf.shift_location_error startpos error)
+          in
+          begin
+            if lexbuf.Lexing.lex_last_action <> Lexbuf.semisemi_action then
+              let rec go () =
+                match Lexer.token lexbuf with
+                | Parser.SEMISEMI | Parser.EOF -> ()
+                | exception Lexer.Error (_, _) -> ()
+                | _ -> go ()
+              in
+              go ()
+          end;
+          Error exn
+    in
+    { startpos; parsed }
+
+  let parse lines =
+    match parse lines with exception End_of_file -> None | t -> Some t
+
+  let top_directive_name (toplevel_phrase : Parsetree.toplevel_phrase) =
+    match toplevel_phrase with
+    | Ptop_def _ -> None
+    | Ptop_dir { pdir_name= { txt; _ }; _ } -> Some txt
+
+  let _is_findlib_directive =
+    let findlib_directive = function
+      | "require" | "camlp4o" | "camlp4r" | "thread" -> true
+      | _ -> false
+    in
+    function
+    | { parsed= Ok toplevel_phrase; _ } -> begin
+        match top_directive_name toplevel_phrase with
+        | Some dir -> findlib_directive dir
+        | None -> false
+      end
+    | _ -> false
+end
+
+let load cfg str = 
+  let ( let* ) = Result.bind in
+  Log.debug (fun m -> m "load: %s" str);
+  let* path = Vif_meta.Path.of_string str in
+  let* deps = Vif_meta.ancestors ~roots:cfg.roots ~predicates:[ "native" ] path in
+  let fn acc (_, path, descr) =
+    let path = match List.assoc_opt "directory" descr with
+      | Some (dir :: _) -> Fpath.(to_dir_path (path / dir))
+      | Some [] | None -> path in
+    match List.assoc_opt "plugin" descr with
+    | Some (plugin :: _) -> Fpath.(path / plugin) :: acc
+    | Some [] | None -> acc in
+  let artifacts = List.fold_left fn [] deps in
+  let artifacts = List.rev artifacts in
+  Log.debug (fun m -> m "load: @[<hov>%a@]"
+    Fmt.(Dump.list Fpath.pp) artifacts);
+  Ok artifacts
+
+let load cfg str =
+  match load cfg str with
+  | Ok artifacts ->
+    let fn artifact =
+      let dir = Fpath.parent artifact in
+      Topdirs.dir_directory (Fpath.(to_string dir));
+      Topdirs.dir_load Fmt.stderr (Fpath.to_string artifact)
+    in
+    List.iter fn artifacts
+  | Error (`Msg msg) ->
+    Log.err (fun m -> m "Impossible to load %S: %s" str msg)
+
+let init cfg =
+  Clflags.native_code := true;
+  Topcommon.update_search_path_from_env ();
+  Topcommon.set_paths ();
+  Toploop.toplevel_env := Compmisc.initial_env ();
+  let objs = !Compenv.first_objfiles in
+  List.iter (Topdirs.dir_load Fmt.stderr) objs;
+  Topcommon.run_hooks Topcommon.Startup;
+  Compmisc.init_path ();
+  Sys.interactive := false;
+  (* Topdirs.dir_directory (Fpath.(to_string cfg.stdlib)); *)
+  Toploop.add_directive "require"
+    (Toploop.Directive_string (load cfg))
+    { Toploop.section= "Vif loader"
+    ; doc= "Load a package" }
+
+let config ~stdlib roots =
+  let cfg = { stdlib; roots } in
+  init cfg; cfg
+
+let eval _cfg ppf ph =
+  match Phrase.result ph with
+  | Error exn -> raise exn
+  | Ok phrase -> begin
+      Warnings.reset_fatal ();
+      let mapper = Lexbuf.position_mapper (Phrase.start ph) in
+      let phrase =
+        match phrase with
+        | Parsetree.Ptop_def str ->
+            Parsetree.Ptop_def (mapper.Ast_mapper.structure mapper str)
+        | Ptop_dir _ as v -> v
+      in
+      let phrase =
+        match phrase with
+        | Ptop_dir _ as v -> v
+        | Ptop_def str ->
+            Ptop_def (Pparse.apply_rewriters_str ~tool_name:"vif" str)
+      in
+      if !Clflags.dump_parsetree then Printast.top_phrase ppf phrase;
+      if !Clflags.dump_source then Pprintast.top_phrase ppf phrase;
+      Env.reset_cache_toplevel ();
+      try Toploop.execute_phrase true (* verbose *) ppf phrase
+      with Compenv.Exit_with_status code ->
+        Format.fprintf ppf "[%d]@." code;
+        false
+    end
+
+let redirect : fn:(capture:(Buffer.t -> unit) -> 'a) -> 'a =
+ fun ~fn ->
+  let filename = Filename.temp_file "vif-" ".stdout" in
+  Log.debug (fun m -> m "redirect stdout/stderr into %s" filename);
+  let stdout' = Unix.dup ~cloexec:true Unix.stdout in
+  let stderr' = Unix.dup ~cloexec:true Unix.stderr in
+  let fd =
+    Unix.openfile filename Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ] 0o600
+  in
+  Unix.dup2 ~cloexec:false fd Unix.stdout;
+  Unix.dup2 ~cloexec:false fd Unix.stderr;
+  let ic = open_in filename in
+  let read_up_to = ref 0 in
+  let capture buf =
+    flush stdout;
+    flush stderr;
+    let pos = Unix.lseek fd 0 Unix.SEEK_CUR in
+    let len = pos - !read_up_to in
+    read_up_to := pos;
+    Buffer.add_channel buf ic len
+  in
+  let finally () =
+    close_in_noerr ic;
+    Unix.close fd;
+    Unix.dup2 ~cloexec:false stdout' Unix.stdout;
+    Unix.dup2 ~cloexec:false stderr' Unix.stderr;
+    Unix.close stdout';
+    Unix.close stderr'
+  in
+  Fun.protect ~finally @@ fun () -> fn ~capture
+
+type vv = V : 'a ref * 'a -> vv
+
+let protect_vars =
+  let set_vars lst = List.iter (fun (V (r, v)) -> r := v) lst in
+  fun vars ~fn ->
+    let backup = List.map (fun (V (r, _)) -> V (r, !r)) vars in
+    set_vars vars;
+    let finally () = set_vars backup in
+    Fun.protect ~finally fn
+
+let capture_compiler_stuff ppf fn =
+  protect_vars [ V (Location.formatter_for_warnings, ppf) ] ~fn
+
+let trim str =
+  let len = String.length str in
+  if len = 0 then str
+  else
+    let trim_from = if str.[0] = '\n' then 1 else 0 in
+    let trim_to = if str.[len - 1] = '\n' then len - 1 else len in
+    if trim_to - trim_from <= 0 then ""
+    else String.sub str trim_from (trim_to - trim_from)
+
+let rec ltrim = function "" :: r -> ltrim r | lst -> lst
+let rtrim lst = List.rev (ltrim (List.rev lst))
+let trim lst = ltrim (rtrim (List.map trim lst))
+
+let rec ends_by_semi_semi = function
+  | [] -> false
+  | [ x ] ->
+      String.length x >= 2
+      && x.[String.length x - 1] = ';'
+      && x.[String.length x - 2] = ';'
+  | _ :: r -> ends_by_semi_semi r
+
+let cut_into_phrases lst =
+  let rec go acc phrase = function
+    | [] -> List.rev (List.rev phrase :: acc)
+    | x :: r when ends_by_semi_semi [ x ] ->
+        go (List.rev (x :: phrase) :: acc) [] r
+    | x :: r -> go acc (x :: phrase) r
+  in
+  go [] [] lst
+
+let eval cfg cmd =
+  let buf = Buffer.create 0x7ff in
+  let ppf = Format.formatter_of_out_channel stderr in
+  errors := false;
+  let eval ~capture phrase =
+    let lines = ref [] in
+    let capture () =
+      capture buf;
+      match Buffer.contents buf with
+      | "" -> ()
+      | str ->
+          Buffer.clear buf;
+          lines := str :: !lines
+    in
+    let out_phrase = !Oprint.out_phrase in
+    let fn_out_phrase ppf = function
+      | Outcometree.Ophr_exception _ as phr -> out_phrase ppf phr
+      | phr -> capture (); out_phrase ppf phr; capture ()
+    in
+    Oprint.out_phrase := fn_out_phrase;
+    let restore () = Oprint.out_phrase := out_phrase in
+    begin
+      match eval cfg ppf phrase with
+      | ok ->
+          errors := (not ok) || !errors;
+          restore ()
+      | exception exn ->
+          errors := true;
+          restore ();
+          Location.report_exception ppf exn
+    end;
+    Format.pp_print_flush ppf ();
+    capture ();
+    trim (List.rev !lines)
+  in
+  Log.debug (fun m -> m "Start to eval: %a" Fmt.(Dump.list (fmt "%S")) cmd);
+  let fn ~capture =
+    capture_compiler_stuff ppf @@ fun () ->
+    let cmd =
+      match cmd with [] | [ _ ] -> cmd | x :: r -> x :: List.map (( ^ ) " ") r
+    in
+    let phrases = cut_into_phrases cmd in
+    let phrases =
+      List.map
+        (fun phrase ->
+          match Phrase.parse phrase with
+          | Some t -> eval ~capture t
+          | None -> [])
+        phrases
+    in
+    let phrases = List.concat phrases in
+    if !errors then Error phrases else Ok phrases
+  in
+  redirect ~fn

lib/vif_top.mli

@@ -0,0 +1,8 @@
+type cfg
+
+val config :
+     stdlib:Fpath.t
+  -> Fpath.t list
+  -> cfg
+
+val eval : cfg -> string list -> (string list, string list) result

vif.opam

@@ -0,0 +1,25 @@
+opam-version: "2.0"
+maintainer: "Robur <team@robur.coop>"
+authors: ["Robur <team@robur.coop>"]
+homepage: "https://github.com/robur-coop/vif"
+dev-repo: "git+https://github.com/robur-coop/vif.git"
+bug-reports: "https://github.com/robur-coop/vif/issues"
+license: "BSD-3-clause"
+
+depends: [
+  "ocaml" {>= "5.0.0"}
+  "dune" {>= "2.0.0"}
+  "fmt"
+  "bos"
+  "logs"
+  "unix"
+  "fpath"
+  "cmdliner"
+]
+conflicts: [ "result" {< "1.5"} ]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+synopsis: ""