.

TODO.md

@@ -1,6 +1,6 @@
-- [ ] be able to load *.cmx{,a} when we use "#require"
+- [x] 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
+- [x] 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

@@ -3,4 +3,4 @@
  (public_name vif)
  (flags
   (:standard -w -18 -linkall))
- (libraries logs.fmt fmt.tty vif.top))
+ (libraries logs.fmt fmt.tty vif vif.top))

bin/vif.ml

@@ -1,4 +1,4 @@
-let reporter ppf =
+let _reporter ppf =
   let report src level ~over k msgf =
     let k _ = over (); k () in
     let with_metadata header _tags k ppf fmt =
@@ -12,36 +12,78 @@ let reporter ppf =
   in
   { Logs.report }
 
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
+
+(*
 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 =
+let run roots stdlib main =
-  [
+  let roots = List.map Fpath.to_string roots in
-    {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|#directory "/home/dinosaure/.opam/5.2.0+ocamlnat/lib/ocaml/";;|ocaml}
-  ; {ocaml|#load "/home/dinosaure/.opam/5.2.0+ocamlnat/lib/ocaml/stdlib.cmxa";;|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
+  let main =
+    let ic = open_in (Fpath.to_string main) in
+    let finally () = close_in ic in
+    Fun.protect ~finally @@ fun () ->
+    let rec go acc =
+      match input_line ic with
+      | line -> go (line :: acc)
+      | exception End_of_file -> List.rev acc
+    in
+    go []
+  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 main =
+  let doc = "The OCaml script to execute." in
+  let parser str =
+    match Fpath.of_string str with
+    | Ok _ as value when Sys.file_exists str && Sys.is_directory str = false ->
+        value
+    | Ok value -> error_msgf "%a does not exists" Fpath.pp value
+    | Error _ as err -> err
+  in
+  let existing_file = Arg.conv (parser, Fpath.pp) in
+  let open Arg in
+  required & pos 0 (some existing_file) None & info [] ~doc ~docv:"FILE"
+
+let setup_stdlib () =
+  let cmd = Bos.Cmd.(v "ocamlopt" % "-config") in
+  let ( let* ) = Result.bind in
+  let* exists = Bos.OS.Cmd.exists cmd in
+  if exists then
+    let r = Bos.OS.Cmd.run_out cmd in
+    let* kvs, _ = Bos.OS.Cmd.out_lines ~trim:true r in
+    let kvs = List.map Astring.String.fields kvs in
+    let kvs =
+      List.fold_left
+        (fun acc -> function k :: v :: _ -> (k, v) :: acc | _ -> acc)
+        [] kvs
+    in
+    match List.assoc_opt "standard_library:" kvs with
+    | Some stdlib -> Fpath.of_string stdlib
+    | None ->
+        error_msgf "Impossible to know where is the OCaml standard library"
+  else error_msgf "ocamlopt is not available"
+
+let setup_stdlib () =
+  match setup_stdlib () with
+  | Ok stdlib -> `Ok stdlib
+  | Error (`Msg msg) -> `Error (false, Fmt.str "%s." msg)
+
+let setup_stdlib =
+  let open Term in
+  ret (const setup_stdlib $ const ())
+
 let term =
   let open Term in
-  const run $ Vif_meta.setup
+  const run $ Vif_meta.setup $ setup_stdlib $ main
 
 let cmd =
   let doc = "vif" in

lib/meta/digest.ml

@@ -1,7 +1,7 @@
 include Stdlib.Digest
 
-let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
-let pp ppf t = Fmt.string ppf (Stdlib.Digest.to_hex t)
+let pp ppf t = Format.pp_print_string ppf (Stdlib.Digest.to_hex t)
 
 let of_string str =
   match of_hex str with

lib/meta/digest.mli

@@ -1,6 +1,6 @@
 include module type of Stdlib.Digest
 
-val pp : t Fmt.t
+val pp : Format.formatter -> t -> unit
 val of_string : string -> (t, [> `Msg of string ]) result
 val length : int
 

lib/meta/dune

@@ -1,15 +1,3 @@
-(library
- (name vif_top)
- (modules vif_top)
- (public_name vif.top)
- (modes native)
- (libraries
-  vif.meta
-  compiler-libs
-  compiler-libs.common
-  compiler-libs.toplevel
-  compiler-libs.native-toplevel))
-
 (ocamllex vif_meta_lexer)
 
 (library

lib/meta/modname.ml

@@ -30,7 +30,7 @@ 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 reflect ppf t = Format.fprintf ppf "(Modname.v %S)" t
 let to_string v = v
 let compare = String.compare
 

lib/meta/modname.mli

@@ -30,13 +30,13 @@ 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
+val pp : Format.formatter -> t -> unit
 (** 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
+val reflect : Format.formatter -> t -> unit
 
 module Map : Map.S with type key = t

lib/meta/objinfo.ml

@@ -2,7 +2,7 @@ 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
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
 
 [@@@warning "-32"]
 
@@ -19,8 +19,8 @@ type t = {
 
 and elt =
   | Qualified of Modname.t * Digest.t
-  | Fully_qualified of Modname.t * Digest.t * Fpath.t
+  | Fully_qualified of Modname.t * Digest.t * string
-  | Located of Modname.t * Fpath.t
+  | Located of Modname.t * string
   | Named of Modname.t
 
 and 'a kind =
@@ -38,7 +38,7 @@ let equal a b =
 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
+  let unit = Unitname.modulize location in
   raise (Inconsistency (unit, name, crc, crc'))
 
 let is_fully_resolved t =
@@ -70,7 +70,7 @@ let of_elt = function
   | Named m -> (m, None)
 
 let exports t = t.exports
-let location t = Fpath.v (Unitname.filepath t.name)
+let location t = 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
@@ -145,27 +145,24 @@ let elt_find modname lst =
     | 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
+  match Cmt_format.read location with
-  | None, _ -> error_msgf "Invalid cmi object: %a" Fpath.pp location
+  | None, _ -> error_msgf "Invalid cmi object: %s" 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 name = Unitname.modulize 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
+  | exception _ -> error_msgf "Invalid cmi object: %s" location
 
 let info_of_cmo ~location ~version ic =
   let cu_pos = input_binary_int ic in
@@ -175,13 +172,13 @@ let info_of_cmo ~location ~version ic =
   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 name = Unitname.modulize 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 name = Unitname.modulize 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
@@ -222,7 +219,7 @@ let info_of_cma ~location ~version ic =
   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
+  let name = Unitname.modulize location in
   Ok { name; version; exports; intfs; impls; format }
 
 let info_of_cmxa ~location ~version ic =
@@ -259,10 +256,10 @@ let info_of_cmxa ~location ~version ic =
   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
+  let name = Unitname.modulize location in
   Ok { name; version; exports; intfs; impls; format }
 
-let is_intf location = Fpath.mem_ext [ ".mli" ] location
+let is_intf location = Filename.extension location = ".mli"
 
 let from_object location { Misc.Magic_number.kind; version } ic =
   let version = Some version in
@@ -272,18 +269,20 @@ let from_object location { Misc.Magic_number.kind; 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
+  | _ -> error_msgf "Unexpected OCaml object: %s" location
 
 let v location =
-  OS.File.with_ic location @@ fun ic () ->
+  let ic = open_in location in
+  let finally () = close_in ic in
+  Fun.protect ~finally @@ fun () ->
   match Misc.Magic_number.read_info ic with
   | Ok info -> from_object location info ic
-  | Error _ -> error_msgf "Invalid object: %a" Fpath.pp location
+  | Error _ -> error_msgf "Invalid object: %s" location
 
-let pp ppf t = Fmt.string ppf (Unitname.filepath t.name)
+let pp ppf t = Format.pp_print_string ppf (Unitname.filepath t.name)
 
 let v location =
-  match v location () |> R.join with
+  match v location with
   | value -> value
   | exception Inconsistency (unit, name, crc, crc') ->
       error_msgf
@@ -303,66 +302,3 @@ let vs lst =
         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/meta/unitname.ml

@@ -18,11 +18,11 @@ let modulize filepath =
   { modname; filepath }
 
 let pp ppf { modname; filepath } =
-  Fmt.pf ppf "%a(%s)" Modname.pp modname filepath
+  Format.fprintf 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 reflect ppf t = Format.fprintf ppf "(Unitname.modulize %S)" t.filepath
 let modname { modname; _ } = modname
 let filename { filepath; _ } = Filename.basename filepath
 let filepath { filepath; _ } = filepath

lib/meta/unitname.mli

@@ -39,10 +39,10 @@ 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 : Format.formatter -> t -> unit
-val pp_as_modname : t Fmt.t
+val pp_as_modname : Format.formatter -> t -> unit
-val pp_as_filepath : t Fmt.t
+val pp_as_filepath : Format.formatter -> t -> unit
-val reflect : t Fmt.t
+val reflect : Format.formatter -> t -> unit
 
 val compare_as_modnames : t -> t -> int
 (** [compare_as_modnames a b] compares [a] and [b] from their modname's views.

lib/meta/vif_meta.ml

@@ -2,7 +2,7 @@ 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
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
 
 type t =
   | Node of { name: string; value: string; contents: t list }
@@ -18,22 +18,24 @@ type t =
 and predicate = Include of string | Exclude of string
 
 let pp_predicate ppf = function
-  | Include p -> Fmt.string ppf p
+  | Include p -> Format.pp_print_string ppf p
-  | Exclude p -> Fmt.pf ppf "-%s" p
+  | Exclude p -> Format.fprintf ppf "-%s" p
 
 let rec pp ppf = function
   | Node { name; value; contents } ->
-      Fmt.pf ppf "%s %S (@\n@[<2>%a@]@\n)" name value
+      Format.fprintf 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 } ->
+      Format.fprintf ppf "%s = %S" name value
   | Set { name; predicates; value } ->
-      Fmt.pf ppf "%s(%a) = %S" name
+      Format.fprintf 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 } ->
+      Format.fprintf ppf "%s += %S" name value
   | Add { name; predicates; value } ->
-      Fmt.pf ppf "%s(%a) += %S" name
+      Format.fprintf ppf "%s(%a) += %S" name
         Fmt.(list ~sep:(any ",") pp_predicate)
         predicates value
 
@@ -70,7 +72,7 @@ module Path = struct
     | Ok pkg -> pkg
     | Error (`Msg msg) -> invalid_arg msg
 
-  let pp ppf pkg = Fmt.string ppf (String.concat "." pkg)
+  let pp ppf pkg = Format.pp_print_string ppf (String.concat "." pkg)
   let equal a b = try List.for_all2 String.equal a b with _ -> false
 end
 
@@ -113,21 +115,21 @@ 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
+  Format.kasprintf
     (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
+  | Vif_meta_lexer.Name name -> Format.pp_print_string ppf name
-  | String str -> Fmt.pf ppf "%S" str
+  | String str -> Format.fprintf ppf "%S" str
-  | Minus -> Fmt.string ppf "-"
+  | Minus -> Format.pp_print_string ppf "-"
-  | Lparen -> Fmt.string ppf "("
+  | Lparen -> Format.pp_print_string ppf "("
-  | Rparen -> Fmt.string ppf ")"
+  | Rparen -> Format.pp_print_string ppf ")"
-  | Comma -> Fmt.string ppf ","
+  | Comma -> Format.pp_print_string ppf ","
-  | Equal -> Fmt.string ppf "="
+  | Equal -> Format.pp_print_string ppf "="
-  | Plus_equal -> Fmt.string ppf "+="
+  | Plus_equal -> Format.pp_print_string ppf "+="
-  | Eof -> Fmt.string ppf "#eof"
+  | Eof -> Format.pp_print_string ppf "#eof"
 
 let invalid_token lexbuf token =
   raise_parser_error lexbuf "Invalid token %a" pp_token token
@@ -202,8 +204,6 @@ let rec parser lexbuf depth acc =
     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)
@@ -211,12 +211,11 @@ let parser lexbuf =
       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 ic = open_in path in
   let@ _ = fun () -> close_in ic in
   let lexbuf = Lexing.from_channel ic in
-  Lexing.set_filename lexbuf (Fpath.to_string path);
+  Lexing.set_filename lexbuf path;
   parser lexbuf
 
 let rec incl us vs =
@@ -230,52 +229,114 @@ let rec diff us vs =
       if u = v then diff us vs else error_msgf "Different paths (%S <> %S)" u v
   | [], x | x, [] -> Ok x
 
+let is_prefix ~prefix path =
+  if not (String.starts_with ~prefix path) then false
+  else
+    let suff_start = String.length prefix in
+    prefix.[suff_start - 1] = Filename.dir_sep.[0]
+    || suff_start = String.length path
+    || path.[suff_start] = Filename.dir_sep.[0]
+
+let segs_to_path segs = String.concat Filename.dir_sep segs
+let segs_of_path = String.split_on_char Filename.dir_sep.[0]
+
+let rem_empty_seg p =
+  match String.length p with
+  | 1 -> p
+  | 2 ->
+      if p.[0] <> Filename.dir_sep.[0] && p.[1] = Filename.dir_sep.[0] then
+        String.make 1 p.[0]
+      else p
+  | len ->
+      let max = len - 1 in
+      if p.[max] <> Filename.dir_sep.[0] then p else String.sub p 0 (max - 1)
+
+let to_dir_path location =
+  if Filename.check_suffix location "/" then location else location ^ "/"
+
+let is_dir_path = Filename.check_suffix Filename.dir_sep
+
+let relativize ~root p =
+  if String.equal root p then
+    Some (segs_to_path (if is_dir_path p then [ "."; "" ] else [ "." ]))
+  else
+    let root =
+      if
+        String.length root > 0
+        && root.[String.length root - 1] = Filename.dir_sep.[0]
+      then root
+      else root ^ Filename.dir_sep
+    in
+    let rec go root p =
+      match (root, p) with
+      | ".." :: _, s :: _ when s <> ".." -> None
+      | sr :: root, sp :: (_ :: _ as p) when sr = sp -> go root p
+      | [ "" ], [ "" ] -> Some (segs_to_path [ "."; "" ])
+      | root, p ->
+          let segs =
+            List.fold_left (fun acc _ -> ".." :: acc) p (List.tl root)
+          in
+          Some (segs_to_path segs)
+    in
+    match (segs_of_path root, segs_of_path p) with
+    | "" :: _, s :: _ when s <> "" -> None
+    | s :: _, "" :: _ when s <> "" -> None
+    | [ "."; "" ], p -> Some (segs_to_path p)
+    | root, p -> go root p
+
 let relativize ~roots path =
   let rec go = function
     | [] -> assert false
     | root :: roots ->
-        if Fpath.is_prefix root path then
+        if is_prefix ~prefix:root path then
-          match Fpath.relativize ~root path with
+          match relativize ~root path with
           | Some rel -> (root, rel)
           | None -> go roots
         else go roots
   in
   go roots
 
+let ( / ) = Filename.concat
+
+module Map = Map.Make (String)
+
 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
+    let path = Fpath.to_string path in
-    else if Fpath.basename path = "META" then Ok true
+    if Sys.is_directory path then Ok false
+    else if Filename.basename path = "META" then Ok true
     else Ok false
   in
   let traverse path =
-    if List.exists (Fpath.equal path) roots then Ok true
+    let path = Fpath.to_string path in
+    if List.exists (String.equal path) roots then Ok true
     else begin
       let _, rel = relativize ~roots path in
-      let meta_path' = Fpath.segs rel in
+      let meta_path' = segs_of_path rel in
       Ok (incl meta_path meta_path')
     end
   in
   let fold path acc =
+    let path = Fpath.to_string path in
     let root, rel = relativize ~roots path in
-    let package = Fpath.(rem_empty_seg (parent rel)) in
+    let package = rem_empty_seg (Filename.dirname rel) in
-    let meta_path' = Fpath.(segs package) in
+    let meta_path' = segs_of_path 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
+    | Ok descr -> Map.add (root / Filename.dirname rel) descr acc
     | Error (`Msg msg) ->
         Log.warn (fun m ->
-            m "Impossible to extract the META file of %a: %s" Fpath.pp path msg);
+            m "Impossible to extract the META file of %s: %s" 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
+    ~traverse:(`Sat traverse) fold Map.empty (List.map Fpath.v roots)
-  >>| Fpath.Map.bindings
+  >>| Map.bindings
 
 let dependencies_of (_path, descr) =
   Stdlib.Option.value ~default:[] (List.assoc_opt "requires" descr)
@@ -338,19 +399,18 @@ let to_artifacts pkgs =
         let directory = List.assoc_opt "directory" pkg in
         let* directory =
           match directory with
-          | Some [ dir ] -> Ok Fpath.(path / dir)
+          | Some [ dir ] -> Ok (path / dir)
           | Some _ ->
-              error_msgf "Multiple directories referenced by %a" Fpath.pp
+              error_msgf "Multiple directories referenced by %s" (path / "META")
-                Fpath.(path / "META")
           | None -> Ok path
         in
-        let directory = Fpath.to_dir_path directory in
+        let directory = 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 archive = List.map (( / ) directory) archive in
-        let plugin = List.map (Fpath.add_seg directory) plugin in
+        let plugin = List.map (( / ) directory) plugin in
         Ok List.(rev_append archive (rev_append plugin acc))
   in
   let* paths = List.fold_left fn (Ok []) pkgs in

lib/meta/vif_meta.mli

@@ -0,0 +1,37 @@
+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 : Format.formatter -> t -> unit
+end
+
+type t
+
+val pp : Format.formatter -> t -> unit
+val parser : string -> (t list, [> `Msg of string ]) result
+
+val search :
+     roots:string list
+  -> ?predicates:string list
+  -> Path.t
+  -> ((string * Assoc.t) list, [> `Msg of string ]) result
+
+val ancestors :
+     roots:string list
+  -> ?predicates:string list
+  -> Path.t
+  -> ((Path.t * string * Assoc.t) list, [> `Msg of string ]) result
+
+val to_artifacts :
+  (string * Assoc.t) list -> (Objinfo.t list, [> `Msg of string ]) result
+
+val setup : Fpath.t list Cmdliner.Term.t
+
+(**/**)
+
+val to_dir_path : string -> string

lib/top/dune

@@ -0,0 +1,12 @@
+(library
+ (name vif_top)
+ (modules vif_top)
+ (public_name vif.top)
+ (modes native)
+ (wrapped false)
+ (libraries
+  vif.meta
+  compiler-libs
+  compiler-libs.common
+  compiler-libs.toplevel
+  compiler-libs.native-toplevel))

lib/top/vif_top.ml

@@ -2,7 +2,7 @@ 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 }
+type cfg = { stdlib: Fpath.t; roots: string list }
 
 let errors = ref false
 
@@ -117,6 +117,9 @@ module Phrase = struct
     | _ -> false
 end
 
+let ( / ) = Filename.concat
+let to_dir_path = Vif_meta.to_dir_path
+
 let load cfg str =
   let ( let* ) = Result.bind in
   Log.debug (fun m -> m "load: %s" str);
@@ -127,25 +130,25 @@ let load cfg str =
   let fn acc (_, path, descr) =
     let path =
       match List.assoc_opt "directory" descr with
-      | Some (dir :: _) -> Fpath.(to_dir_path (path / dir))
+      | Some (dir :: _) -> to_dir_path (path / dir)
       | Some [] | None -> path
     in
     match List.assoc_opt "plugin" descr with
-    | Some (plugin :: _) -> Fpath.(path / plugin) :: acc
+    | Some (plugin :: _) -> (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);
+  Log.debug (fun m -> m "load: @[<hov>%a@]" Fmt.(Dump.list string) artifacts);
   Ok artifacts
 
 let load cfg str =
   match load cfg str with
   | Ok artifacts ->
       let fn artifact =
-        let dir = Fpath.parent artifact in
+        let dir = Filename.dirname artifact in
-        Topdirs.dir_directory Fpath.(to_string dir);
+        Topdirs.dir_directory dir;
-        Topdirs.dir_load Fmt.stderr (Fpath.to_string artifact)
+        Topdirs.dir_load Fmt.stderr artifact
       in
       List.iter fn artifacts
   | Error (`Msg msg) -> Log.err (fun m -> m "Impossible to load %S: %s" str msg)
@@ -198,7 +201,7 @@ let eval _cfg ppf ph =
       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
+      try Toploop.execute_phrase false (* verbose *) ppf phrase
       with Compenv.Exit_with_status code ->
         Format.fprintf ppf "[%d]@." code;
         false
@@ -231,7 +234,8 @@ let redirect : fn:(capture:(Buffer.t -> unit) -> 'a) -> 'a =
     Unix.dup2 ~cloexec:false stdout' Unix.stdout;
     Unix.dup2 ~cloexec:false stderr' Unix.stderr;
     Unix.close stdout';
-    Unix.close stderr'
+    Unix.close stderr';
+    Sys.remove filename
   in
   Fun.protect ~finally @@ fun () -> fn ~capture
 
@@ -313,7 +317,6 @@ let eval cfg cmd =
     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 =

lib/top/vif_top.mli

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

lib/vif/dune

@@ -0,0 +1,4 @@
+(library
+ (name vif)
+ (public_name vif)
+ (libraries httpcats tyre))

lib/vif/pct.ml

@@ -0,0 +1,65 @@
+let safe = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.-~"
+
+let pchar =
+  let arr = Array.make 256 false in
+  for i = 0 to String.length safe - 1 do
+    arr.(Char.code safe.[i]) <- true
+  done;
+  arr.(Char.code ':') <- true;
+  arr.(Char.code '@') <- true;
+  arr
+
+let safe_path =
+  let v = "!$&'()*+,;=" in
+  let arr = Array.copy pchar in
+  for i = 0 to String.length v - 1 do
+    arr.(Char.code v.[i]) <- true
+  done;
+  arr.(Char.code '/') <- true;
+  arr
+
+let safe_query =
+  let arr = Array.copy pchar in
+  arr.(Char.code '/') <- true;
+  arr.(Char.code '?') <- true;
+  arr.(Char.code '&') <- false;
+  arr.(Char.code ';') <- false;
+  arr.(Char.code '+') <- false;
+  arr
+
+let safe_query_key =
+  let arr = Array.copy safe_query in
+  arr.(Char.code '=') <- false;
+  arr
+
+let safe_query_value =
+  let arr = Array.copy safe_query in
+  arr.(Char.code ',') <- false;
+  arr
+
+let encode safe_chars str =
+  let len = String.length str in
+  let buf = Buffer.create len in
+  let rec scan start cur =
+    if cur >= len then Buffer.add_substring buf str start (cur - start)
+    else if safe_chars.(Char.code str.[cur]) then scan start (succ cur)
+    else begin
+      if cur > start then Buffer.add_substring buf str start (cur - start);
+      Buffer.add_string buf (Format.asprintf "%%%02X" (Char.code str.[cur]));
+      scan (succ cur) (succ cur)
+    end
+  in
+  scan 0 0; Buffer.contents buf
+
+let encode_path str = encode safe_path str
+
+let encode_query lst =
+  let enc =
+    List.map
+      (fun (k, vs) ->
+        let k' = encode safe_query_key k in
+        let vs' = List.map (encode safe_query_value) vs in
+        k' ^ "=" ^ String.concat "," vs')
+      lst
+  in
+  match lst with _ :: _ -> "?" ^ String.concat "&" enc | [] -> ""

lib/vif/pct.mli

@@ -0,0 +1,2 @@
+val encode_path : string -> string
+val encode_query : (string * string list) list -> string

lib/vif/vif.ml

@@ -0,0 +1 @@
+module U = Vif_u

lib/vif/vif.mli

@@ -0,0 +1 @@
+module U = Vif_u

lib/vif/vif_u.ml

@@ -0,0 +1,132 @@
+type 'a atom = 'a Tyre.t
+
+module Types = struct
+  type ('fu, 'return) path =
+    | Host : string -> ('r, 'r) path
+    | Rel : ('r, 'r) path
+    | Path_const : ('f, 'r) path * string -> ('f, 'r) path
+    | Path_atom : ('f, 'a -> 'r) path * 'a atom -> ('f, 'r) path
+
+  type ('fu, 'return) query =
+    | Nil : ('r, 'r) query
+    | Any : ('r, 'r) query
+    | Query_atom : string * 'a atom * ('f, 'r) query -> ('a -> 'f, 'r) query
+
+  type slash = Slash | No_slash | Maybe_slash
+
+  type ('f, 'r) url =
+    | Url : slash * ('f, 'x) path * ('x, 'r) query -> ('f, 'r) url
+end
+
+module Path = struct
+  type ('f, 'r) t = ('f, 'r) Types.path
+
+  open Types
+
+  let host str = Host str
+  let relative = Rel
+  let add path str = Path_const (path, str)
+  let add_atom path atom = Path_atom (path, atom)
+
+  let rec _concat : type f r x. (f, x) t -> (x, r) t -> (f, r) t =
+   fun p1 p2 ->
+    match p2 with
+    | Host _ -> p1
+    | Rel -> p1
+    | Path_const (p, str) -> Path_const (_concat p1 p, str)
+    | Path_atom (p, a) -> Path_atom (_concat p1 p, a)
+end
+
+module Query = struct
+  type ('f, 'r) t = ('f, 'r) Types.query
+
+  open Types
+
+  let nil : _ t = Nil
+  let any = Any
+  let add n x query = Query_atom (n, x, query)
+
+  let rec make_any : type f r. (f, r) t -> (f, r) t = function
+    | Nil -> Any
+    | Any -> Any
+    | Query_atom (n, x, q) -> Query_atom (n, x, make_any q)
+
+  let rec _concat : type f r x. (f, x) t -> (x, r) t -> (f, r) t =
+   fun q1 q2 ->
+    match q1 with
+    | Nil -> q2
+    | Any -> make_any q2
+    | Query_atom (n, x, q) -> Query_atom (n, x, _concat q q2)
+end
+
+module Url = struct
+  type ('f, 'r) t = ('f, 'r) Types.url
+
+  open Types
+
+  let make ?(slash = No_slash) path query : _ t = Url (slash, path, query)
+end
+
+type ('f, 'r) path = ('f, 'r) Path.t
+type ('f, 'r) query = ('f, 'r) Query.t
+type ('f, 'r) t = ('f, 'r) Url.t
+
+let nil = Query.nil
+let any = Query.any
+let ( ** ) (n, x) q = Query.add n x q
+let host = Path.host
+let rel = Path.relative
+let ( / ) = Path.add
+let ( /% ) = Path.add_atom
+let ( /? ) path query = Url.make ~slash:No_slash path query
+let ( //? ) path query = Url.make ~slash:Slash path query
+let ( /?? ) path query = Url.make ~slash:Maybe_slash path query
+let eval_atom p x = Tyre.(eval (Internal.to_t p) x)
+
+let eval_top_atom : type a. a Tyre.Internal.raw -> a -> string list = function
+  | Opt p -> ( function None -> [] | Some x -> [ eval_atom p x ])
+  | Rep p -> fun l -> List.of_seq (Seq.map (eval_atom p) l)
+  | e -> fun x -> [ eval_atom e x ]
+
+let rec eval_path : type r f.
+    (f, r) Path.t -> (string option -> string list -> r) -> f =
+ fun p k ->
+  match p with
+  | Host str -> k (Some str) []
+  | Rel -> k None []
+  | Path_const (p, str) -> eval_path p (fun h r -> k h (str :: r))
+  | Path_atom (p, a) ->
+      let fn h r x = k h (eval_top_atom (Tyre.Internal.from_t a) x @ r) in
+      eval_path p fn
+
+let rec eval_query : type r f.
+    (f, r) Query.t -> ((string * string list) list -> r) -> f =
+ fun q k ->
+  match q with
+  | Nil -> k []
+  | Any -> k []
+  | Query_atom (n, a, q) ->
+      fun x ->
+        let fn r = k ((n, eval_top_atom (Tyre.Internal.from_t a) x) :: r) in
+        eval_query q fn
+
+let keval : ('a, 'b) t -> (string -> 'b) -> 'a =
+ fun (Url (slash, p, q)) k ->
+  eval_path p @@ fun host path ->
+  eval_query q @@ fun query ->
+  let path =
+    match slash with Slash -> "" :: path | No_slash | Maybe_slash -> path
+  in
+  let host = Option.value ~default:"" host in
+  let path = String.concat "/" (List.rev path) in
+  let path = Pct.encode_path path in
+  let query = Pct.encode_query query in
+  k (host ^ path ^ query)
+
+let eval t = keval t Fun.id
+
+type 'a handler = 'a Httpcats.handler
+type response = Httpcats.response
+type error = Httpcats.error
+
+let request ~f a t = keval t @@ fun uri -> Httpcats.request ~f ~uri a

lib/vif/vif_u.mli

@@ -0,0 +1,30 @@
+type 'a atom = 'a Tyre.t
+type ('f, 'r) path
+
+val rel : ('r, 'r) path
+val host : string -> ('r, 'r) path
+val ( / ) : ('f, 'r) path -> string -> ('f, 'r) path
+val ( /% ) : ('f, 'a -> 'r) path -> 'a atom -> ('f, 'r) path
+
+type ('f, 'r) query
+
+val nil : ('r, 'r) query
+val any : ('r, 'r) query
+val ( ** ) : string * 'a atom -> ('f, 'r) query -> ('a -> 'f, 'r) query
+
+type ('f, 'r) t
+
+val ( /? ) : ('f, 'x) path -> ('x, 'r) query -> ('f, 'r) t
+val ( //? ) : ('f, 'x) path -> ('x, 'r) query -> ('f, 'r) t
+val ( /?? ) : ('f, 'x) path -> ('x, 'r) query -> ('f, 'r) t
+
+(**/**)
+
+val keval : ('f, 'r) t -> (string -> 'r) -> 'f
+val eval : ('f, string) t -> 'f
+
+type 'a handler = 'a Httpcats.handler
+type response = Httpcats.response
+type error = Httpcats.error
+
+val request : f:'a handler -> 'a -> ('f, (response * 'a, error) result) t -> 'f

lib/vif_meta.mli

@@ -1,33 +0,0 @@
-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