From b6300126670c0f65a19feb8073ed5d15e88f6ff4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sat, 4 Jan 2025 10:08:36 +0100 Subject: [PATCH] . --- TODO.md | 4 +- bin/dune | 2 +- bin/vif.ml | 78 ++++++++++++---- lib/{ => meta}/digest.ml | 4 +- lib/{ => meta}/digest.mli | 2 +- lib/{ => meta}/dune | 12 --- lib/{ => meta}/modname.ml | 2 +- lib/{ => meta}/modname.mli | 4 +- lib/{ => meta}/objinfo.ml | 106 +++++----------------- lib/{ => meta}/unitname.ml | 4 +- lib/{ => meta}/unitname.mli | 8 +- lib/{ => meta}/vif_meta.ml | 144 +++++++++++++++++++++--------- lib/meta/vif_meta.mli | 37 ++++++++ lib/{ => meta}/vif_meta_lexer.mll | 0 lib/top/dune | 12 +++ lib/{ => top}/vif_top.ml | 23 ++--- lib/{ => top}/vif_top.mli | 2 +- lib/vif/dune | 4 + lib/vif/pct.ml | 65 ++++++++++++++ lib/vif/pct.mli | 2 + lib/vif/vif.ml | 1 + lib/vif/vif.mli | 1 + lib/vif/vif_u.ml | 132 +++++++++++++++++++++++++++ lib/vif/vif_u.mli | 30 +++++++ lib/vif_meta.mli | 33 ------- 25 files changed, 496 insertions(+), 216 deletions(-) rename lib/{ => meta}/digest.ml (66%) rename lib/{ => meta}/digest.mli (79%) rename lib/{ => meta}/dune (55%) rename lib/{ => meta}/modname.ml (94%) rename lib/{ => meta}/modname.mli (93%) rename lib/{ => meta}/objinfo.ml (74%) rename lib/{ => meta}/unitname.ml (92%) rename lib/{ => meta}/unitname.mli (93%) rename lib/{ => meta}/vif_meta.ml (74%) create mode 100644 lib/meta/vif_meta.mli rename lib/{ => meta}/vif_meta_lexer.mll (100%) create mode 100644 lib/top/dune rename lib/{ => top}/vif_top.ml (94%) rename lib/{ => top}/vif_top.mli (60%) create mode 100644 lib/vif/dune create mode 100644 lib/vif/pct.ml create mode 100644 lib/vif/pct.mli create mode 100644 lib/vif/vif.ml create mode 100644 lib/vif/vif.mli create mode 100644 lib/vif/vif_u.ml create mode 100644 lib/vif/vif_u.mli delete mode 100644 lib/vif_meta.mli diff --git a/TODO.md b/TODO.md index b9ca2ed..d2697c4 100644 --- a/TODO.md +++ b/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` diff --git a/bin/dune b/bin/dune index 5e3911c..23abbb8 100644 --- a/bin/dune +++ b/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)) diff --git a/bin/vif.ml b/bin/vif.ml index 1e27545..4998b7c 100644 --- a/bin/vif.ml +++ b/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 = - [ - {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 run roots stdlib main = + let roots = List.map Fpath.to_string roots in 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 diff --git a/lib/digest.ml b/lib/meta/digest.ml similarity index 66% rename from lib/digest.ml rename to lib/meta/digest.ml index b86be46..f1206f8 100644 --- a/lib/digest.ml +++ b/lib/meta/digest.ml @@ -1,7 +1,7 @@ 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 error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt +let pp ppf t = Format.pp_print_string ppf (Stdlib.Digest.to_hex t) let of_string str = match of_hex str with diff --git a/lib/digest.mli b/lib/meta/digest.mli similarity index 79% rename from lib/digest.mli rename to lib/meta/digest.mli index 03bcfad..52ad2f7 100644 --- a/lib/digest.mli +++ b/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 diff --git a/lib/dune b/lib/meta/dune similarity index 55% rename from lib/dune rename to lib/meta/dune index 857b158..581e345 100644 --- a/lib/dune +++ b/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 diff --git a/lib/modname.ml b/lib/meta/modname.ml similarity index 94% rename from lib/modname.ml rename to lib/meta/modname.ml index c381176..e722842 100644 --- a/lib/modname.ml +++ b/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 diff --git a/lib/modname.mli b/lib/meta/modname.mli similarity index 93% rename from lib/modname.mli rename to lib/meta/modname.mli index ded907f..63b58cf 100644 --- a/lib/modname.mli +++ b/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 diff --git a/lib/objinfo.ml b/lib/meta/objinfo.ml similarity index 74% rename from lib/objinfo.ml rename to lib/meta/objinfo.ml index 99e87c5..b1b535c 100644 --- a/lib/objinfo.ml +++ b/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 - | Located of Modname.t * Fpath.t + | Fully_qualified of Modname.t * Digest.t * string + | 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 - | None, _ -> error_msgf "Invalid cmi object: %a" Fpath.pp location + match Cmt_format.read location with + | 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 diff --git a/lib/unitname.ml b/lib/meta/unitname.ml similarity index 92% rename from lib/unitname.ml rename to lib/meta/unitname.ml index 6ebe08c..8896986 100644 --- a/lib/unitname.ml +++ b/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 diff --git a/lib/unitname.mli b/lib/meta/unitname.mli similarity index 93% rename from lib/unitname.mli rename to lib/meta/unitname.mli index 411a9db..9d6b937 100644 --- a/lib/unitname.mli +++ b/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_as_modname : t Fmt.t -val pp_as_filepath : t Fmt.t -val reflect : t Fmt.t +val pp : Format.formatter -> t -> unit +val pp_as_modname : Format.formatter -> t -> unit +val pp_as_filepath : Format.formatter -> t -> unit +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. diff --git a/lib/vif_meta.ml b/lib/meta/vif_meta.ml similarity index 74% rename from lib/vif_meta.ml rename to lib/meta/vif_meta.ml index fd4a561..a17cbc7 100644 --- a/lib/vif_meta.ml +++ b/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 - | Exclude p -> Fmt.pf ppf "-%s" p + | Include p -> Format.pp_print_string ppf 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 - | 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" + | Vif_meta_lexer.Name name -> Format.pp_print_string ppf name + | String str -> Format.fprintf ppf "%S" str + | Minus -> Format.pp_print_string ppf "-" + | Lparen -> Format.pp_print_string ppf "(" + | Rparen -> Format.pp_print_string ppf ")" + | Comma -> Format.pp_print_string ppf "," + | Equal -> Format.pp_print_string ppf "=" + | Plus_equal -> Format.pp_print_string ppf "+=" + | 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 - match Fpath.relativize ~root path with + if is_prefix ~prefix:root path then + 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 - else if Fpath.basename path = "META" then Ok true + let path = Fpath.to_string path in + 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 meta_path' = Fpath.(segs package) in + let package = rem_empty_seg (Filename.dirname rel) 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 - >>| Fpath.Map.bindings + ~traverse:(`Sat traverse) fold Map.empty (List.map Fpath.v roots) + >>| 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 - Fpath.(path / "META") + error_msgf "Multiple directories referenced by %s" (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 plugin = List.map (Fpath.add_seg directory) plugin in + let archive = List.map (( / ) directory) archive 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 diff --git a/lib/meta/vif_meta.mli b/lib/meta/vif_meta.mli new file mode 100644 index 0000000..348af3c --- /dev/null +++ b/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 diff --git a/lib/vif_meta_lexer.mll b/lib/meta/vif_meta_lexer.mll similarity index 100% rename from lib/vif_meta_lexer.mll rename to lib/meta/vif_meta_lexer.mll diff --git a/lib/top/dune b/lib/top/dune new file mode 100644 index 0000000..cc7e4ba --- /dev/null +++ b/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)) diff --git a/lib/vif_top.ml b/lib/top/vif_top.ml similarity index 94% rename from lib/vif_top.ml rename to lib/top/vif_top.ml index 57cbb7f..564ee62 100644 --- a/lib/vif_top.ml +++ b/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: @[%a@]" Fmt.(Dump.list Fpath.pp) artifacts); + Log.debug (fun m -> m "load: @[%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 - Topdirs.dir_directory Fpath.(to_string dir); - Topdirs.dir_load Fmt.stderr (Fpath.to_string artifact) + let dir = Filename.dirname artifact in + Topdirs.dir_directory dir; + 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 = diff --git a/lib/vif_top.mli b/lib/top/vif_top.mli similarity index 60% rename from lib/vif_top.mli rename to lib/top/vif_top.mli index a5e1614..5fae63f 100644 --- a/lib/vif_top.mli +++ b/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 diff --git a/lib/vif/dune b/lib/vif/dune new file mode 100644 index 0000000..c043a2c --- /dev/null +++ b/lib/vif/dune @@ -0,0 +1,4 @@ +(library + (name vif) + (public_name vif) + (libraries httpcats tyre)) diff --git a/lib/vif/pct.ml b/lib/vif/pct.ml new file mode 100644 index 0000000..5590227 --- /dev/null +++ b/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 | [] -> "" diff --git a/lib/vif/pct.mli b/lib/vif/pct.mli new file mode 100644 index 0000000..3b268a3 --- /dev/null +++ b/lib/vif/pct.mli @@ -0,0 +1,2 @@ +val encode_path : string -> string +val encode_query : (string * string list) list -> string diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml new file mode 100644 index 0000000..45c6bbf --- /dev/null +++ b/lib/vif/vif.ml @@ -0,0 +1 @@ +module U = Vif_u diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli new file mode 100644 index 0000000..45c6bbf --- /dev/null +++ b/lib/vif/vif.mli @@ -0,0 +1 @@ +module U = Vif_u diff --git a/lib/vif/vif_u.ml b/lib/vif/vif_u.ml new file mode 100644 index 0000000..fd9db65 --- /dev/null +++ b/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 diff --git a/lib/vif/vif_u.mli b/lib/vif/vif_u.mli new file mode 100644 index 0000000..1c8aba3 --- /dev/null +++ b/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 diff --git a/lib/vif_meta.mli b/lib/vif_meta.mli deleted file mode 100644 index 884107d..0000000 --- a/lib/vif_meta.mli +++ /dev/null @@ -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