swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

668
unikernel/duniverse/dune_/otherlibs/stdune/src/ansi_color.ml Normal file
View file

@ -0,0 +1,668 @@
module RGB8 : sig
type t
val to_dyn : t -> Dyn.t
val of_int : int -> t
val to_int : t -> int
val of_char : char -> t
val to_char : t -> char
val compare : t -> t -> Ordering.t
(* This is only used internally. *)
val write_to_buffer : Buffer.t -> t -> unit
end = struct
type t = char
let of_char t = t
let to_char t = t
let to_dyn t = Dyn.Int (int_of_char t)
let of_int t = char_of_int (t land 0xFF)
let to_int t = int_of_char t
let compare t1 t2 = Char.compare t1 t2
let write_to_buffer buf c =
Buffer.add_string buf "38;5;";
int_of_char c |> Int.to_string |> Buffer.add_string buf
;;
end
module RGB24 : sig
type t
val to_dyn : t -> Dyn.t
val compare : t -> t -> Ordering.t
val red : t -> int
val green : t -> int
val blue : t -> int
val make : red:int -> green:int -> blue:int -> t
val to_int : t -> int
val of_int : int -> t
(* This is only used internally. *)
val write_to_buffer : Buffer.t -> t -> unit
end = struct
type t = int
let compare = Int.compare
let red t = Int.shift_right t 16 land 0xFF
let green t = Int.shift_right t 8 land 0xFF
let blue t = t land 0xFF
let to_dyn t = Dyn.list Dyn.int [ red t; green t; blue t ]
let to_int t = t
let of_int t = t
let make ~red ~green ~blue =
((red land 0xFF) lsl 16) lor ((green land 0xFF) lsl 8) lor (blue land 0xFF)
;;
let write_to_buffer buf t =
Buffer.add_string buf "38;2;";
red t |> Int.to_string |> Buffer.add_string buf;
Buffer.add_char buf ';';
green t |> Int.to_string |> Buffer.add_string buf;
Buffer.add_char buf ';';
blue t |> Int.to_string |> Buffer.add_string buf
;;
end
module Style = struct
type t =
[ `Fg_default
| `Fg_black
| `Fg_red
| `Fg_green
| `Fg_yellow
| `Fg_blue
| `Fg_magenta
| `Fg_cyan
| `Fg_white
| `Fg_bright_black
| `Fg_bright_red
| `Fg_bright_green
| `Fg_bright_yellow
| `Fg_bright_blue
| `Fg_bright_magenta
| `Fg_bright_cyan
| `Fg_bright_white
| `Fg_8_bit_color of RGB8.t
| `Fg_24_bit_color of RGB24.t
| `Bg_default
| `Bg_black
| `Bg_red
| `Bg_green
| `Bg_yellow
| `Bg_blue
| `Bg_magenta
| `Bg_cyan
| `Bg_white
| `Bg_bright_black
| `Bg_bright_red
| `Bg_bright_green
| `Bg_bright_yellow
| `Bg_bright_blue
| `Bg_bright_magenta
| `Bg_bright_cyan
| `Bg_bright_white
| `Bg_8_bit_color of RGB8.t
| `Bg_24_bit_color of RGB24.t
| `Bold
| `Dim
| `Italic
| `Underline
]
let write_to_buffer buf : t -> unit = function
| `Fg_default -> Buffer.add_string buf "39"
| `Fg_black -> Buffer.add_string buf "30"
| `Fg_red -> Buffer.add_string buf "31"
| `Fg_green -> Buffer.add_string buf "32"
| `Fg_yellow -> Buffer.add_string buf "33"
| `Fg_blue -> Buffer.add_string buf "34"
| `Fg_magenta -> Buffer.add_string buf "35"
| `Fg_cyan -> Buffer.add_string buf "36"
| `Fg_white -> Buffer.add_string buf "37"
| `Fg_bright_black -> Buffer.add_string buf "90"
| `Fg_bright_red -> Buffer.add_string buf "91"
| `Fg_bright_green -> Buffer.add_string buf "92"
| `Fg_bright_yellow -> Buffer.add_string buf "93"
| `Fg_bright_blue -> Buffer.add_string buf "94"
| `Fg_bright_magenta -> Buffer.add_string buf "95"
| `Fg_bright_cyan -> Buffer.add_string buf "96"
| `Fg_bright_white -> Buffer.add_string buf "97"
| `Fg_8_bit_color c -> RGB8.write_to_buffer buf c
| `Fg_24_bit_color rgb -> RGB24.write_to_buffer buf rgb
| `Bg_default -> Buffer.add_string buf "49"
| `Bg_black -> Buffer.add_string buf "40"
| `Bg_red -> Buffer.add_string buf "41"
| `Bg_green -> Buffer.add_string buf "42"
| `Bg_yellow -> Buffer.add_string buf "43"
| `Bg_blue -> Buffer.add_string buf "44"
| `Bg_magenta -> Buffer.add_string buf "45"
| `Bg_cyan -> Buffer.add_string buf "46"
| `Bg_white -> Buffer.add_string buf "47"
| `Bg_bright_black -> Buffer.add_string buf "100"
| `Bg_bright_red -> Buffer.add_string buf "101"
| `Bg_bright_green -> Buffer.add_string buf "102"
| `Bg_bright_yellow -> Buffer.add_string buf "103"
| `Bg_bright_blue -> Buffer.add_string buf "104"
| `Bg_bright_magenta -> Buffer.add_string buf "105"
| `Bg_bright_cyan -> Buffer.add_string buf "106"
| `Bg_bright_white -> Buffer.add_string buf "107"
| `Bg_8_bit_color c -> RGB8.write_to_buffer buf c
| `Bg_24_bit_color rgb -> RGB24.write_to_buffer buf rgb
| `Bold -> Buffer.add_string buf "1"
| `Dim -> Buffer.add_string buf "2"
| `Italic -> Buffer.add_string buf "3"
| `Underline -> Buffer.add_string buf "4"
;;
let to_dyn : t -> Dyn.t = function
| `Fg_default -> Dyn.variant "Fg_default" []
| `Fg_black -> Dyn.variant "Fg_black" []
| `Fg_red -> Dyn.variant "Fg_red" []
| `Fg_green -> Dyn.variant "Fg_green" []
| `Fg_yellow -> Dyn.variant "Fg_yellow" []
| `Fg_blue -> Dyn.variant "Fg_blue" []
| `Fg_magenta -> Dyn.variant "Fg_magenta" []
| `Fg_cyan -> Dyn.variant "Fg_cyan" []
| `Fg_white -> Dyn.variant "Fg_white" []
| `Fg_bright_black -> Dyn.variant "Fg_bright_black" []
| `Fg_bright_red -> Dyn.variant "Fg_bright_red" []
| `Fg_bright_green -> Dyn.variant "Fg_bright_green" []
| `Fg_bright_yellow -> Dyn.variant "Fg_bright_yellow" []
| `Fg_bright_blue -> Dyn.variant "Fg_bright_blue" []
| `Fg_bright_magenta -> Dyn.variant "Fg_bright_magenta" []
| `Fg_bright_cyan -> Dyn.variant "Fg_bright_cyan" []
| `Fg_bright_white -> Dyn.variant "Fg_bright_white" []
| `Fg_8_bit_color c -> Dyn.variant "Fg_8_bit_color" [ RGB8.to_dyn c ]
| `Fg_24_bit_color rgb -> Dyn.variant "Fg_24_bit_color" [ RGB24.to_dyn rgb ]
| `Bg_default -> Dyn.variant "Bg_default" []
| `Bg_black -> Dyn.variant "Bg_black" []
| `Bg_red -> Dyn.variant "Bg_red" []
| `Bg_green -> Dyn.variant "Bg_green" []
| `Bg_yellow -> Dyn.variant "Bg_yellow" []
| `Bg_blue -> Dyn.variant "Bg_blue" []
| `Bg_magenta -> Dyn.variant "Bg_magenta" []
| `Bg_cyan -> Dyn.variant "Bg_cyan" []
| `Bg_white -> Dyn.variant "Bg_white" []
| `Bg_bright_black -> Dyn.variant "Bg_bright_black" []
| `Bg_bright_red -> Dyn.variant "Bg_bright_red" []
| `Bg_bright_green -> Dyn.variant "Bg_bright_green" []
| `Bg_bright_yellow -> Dyn.variant "Bg_bright_yellow" []
| `Bg_bright_blue -> Dyn.variant "Bg_bright_blue" []
| `Bg_bright_magenta -> Dyn.variant "Bg_bright_magenta" []
| `Bg_bright_cyan -> Dyn.variant "Bg_bright_cyan" []
| `Bg_bright_white -> Dyn.variant "Bg_bright_white" []
| `Bg_8_bit_color c -> Dyn.variant "Bg_8_bit_color" [ RGB8.to_dyn c ]
| `Bg_24_bit_color rgb -> Dyn.variant "Bg_24_bit_color" [ RGB24.to_dyn rgb ]
| `Bold -> Dyn.variant "Bold" []
| `Dim -> Dyn.variant "Dim" []
| `Italic -> Dyn.variant "Italic" []
| `Underline -> Dyn.variant "Underline" []
;;
let compare (t1 : t) (t2 : t) : Ordering.t =
match t1, t2 with
| `Fg_default, `Fg_default -> Eq
| `Fg_default, _ -> Lt
| _, `Fg_default -> Gt
| `Fg_black, `Fg_black -> Eq
| `Fg_black, _ -> Lt
| _, `Fg_black -> Gt
| `Fg_red, `Fg_red -> Eq
| `Fg_red, _ -> Lt
| _, `Fg_red -> Gt
| `Fg_green, `Fg_green -> Eq
| `Fg_green, _ -> Lt
| _, `Fg_green -> Gt
| `Fg_yellow, `Fg_yellow -> Eq
| `Fg_yellow, _ -> Lt
| _, `Fg_yellow -> Gt
| `Fg_blue, `Fg_blue -> Eq
| `Fg_blue, _ -> Lt
| _, `Fg_blue -> Gt
| `Fg_magenta, `Fg_magenta -> Eq
| `Fg_magenta, _ -> Lt
| _, `Fg_magenta -> Gt
| `Fg_cyan, `Fg_cyan -> Eq
| `Fg_cyan, _ -> Lt
| _, `Fg_cyan -> Gt
| `Fg_white, `Fg_white -> Eq
| `Fg_white, _ -> Lt
| _, `Fg_white -> Gt
| `Fg_bright_black, `Fg_bright_black -> Eq
| `Fg_bright_black, _ -> Lt
| _, `Fg_bright_black -> Gt
| `Fg_bright_red, `Fg_bright_red -> Eq
| `Fg_bright_red, _ -> Lt
| _, `Fg_bright_red -> Gt
| `Fg_bright_green, `Fg_bright_green -> Eq
| `Fg_bright_green, _ -> Lt
| _, `Fg_bright_green -> Gt
| `Fg_bright_yellow, `Fg_bright_yellow -> Eq
| `Fg_bright_yellow, _ -> Lt
| _, `Fg_bright_yellow -> Gt
| `Fg_bright_blue, `Fg_bright_blue -> Eq
| `Fg_bright_blue, _ -> Lt
| _, `Fg_bright_blue -> Gt
| `Fg_bright_magenta, `Fg_bright_magenta -> Eq
| `Fg_bright_magenta, _ -> Lt
| _, `Fg_bright_magenta -> Gt
| `Fg_bright_cyan, `Fg_bright_cyan -> Eq
| `Fg_bright_cyan, _ -> Lt
| _, `Fg_bright_cyan -> Gt
| `Fg_bright_white, `Fg_bright_white -> Eq
| `Fg_bright_white, _ -> Lt
| _, `Fg_bright_white -> Gt
| `Fg_8_bit_color c1, `Fg_8_bit_color c2 -> RGB8.compare c1 c2
| `Fg_8_bit_color _, _ -> Lt
| _, `Fg_8_bit_color _ -> Gt
| `Fg_24_bit_color c1, `Fg_24_bit_color c2 -> RGB24.compare c1 c2
| `Fg_24_bit_color _, _ -> Lt
| _, `Fg_24_bit_color _ -> Gt
| `Bg_default, `Bg_default -> Eq
| `Bg_default, _ -> Lt
| _, `Bg_default -> Gt
| `Bg_black, `Bg_black -> Eq
| `Bg_black, _ -> Lt
| _, `Bg_black -> Gt
| `Bg_red, `Bg_red -> Eq
| `Bg_red, _ -> Lt
| _, `Bg_red -> Gt
| `Bg_green, `Bg_green -> Eq
| `Bg_green, _ -> Lt
| _, `Bg_green -> Gt
| `Bg_yellow, `Bg_yellow -> Eq
| `Bg_yellow, _ -> Lt
| _, `Bg_yellow -> Gt
| `Bg_blue, `Bg_blue -> Eq
| `Bg_blue, _ -> Lt
| _, `Bg_blue -> Gt
| `Bg_magenta, `Bg_magenta -> Eq
| `Bg_magenta, _ -> Lt
| _, `Bg_magenta -> Gt
| `Bg_cyan, `Bg_cyan -> Eq
| `Bg_cyan, _ -> Lt
| _, `Bg_cyan -> Gt
| `Bg_white, `Bg_white -> Eq
| `Bg_white, _ -> Lt
| _, `Bg_white -> Gt
| `Bg_bright_black, `Bg_bright_black -> Eq
| `Bg_bright_black, _ -> Lt
| _, `Bg_bright_black -> Gt
| `Bg_bright_red, `Bg_bright_red -> Eq
| `Bg_bright_red, _ -> Lt
| _, `Bg_bright_red -> Gt
| `Bg_bright_green, `Bg_bright_green -> Eq
| `Bg_bright_green, _ -> Lt
| _, `Bg_bright_green -> Gt
| `Bg_bright_yellow, `Bg_bright_yellow -> Eq
| `Bg_bright_yellow, _ -> Lt
| _, `Bg_bright_yellow -> Gt
| `Bg_bright_blue, `Bg_bright_blue -> Eq
| `Bg_bright_blue, _ -> Lt
| _, `Bg_bright_blue -> Gt
| `Bg_bright_magenta, `Bg_bright_magenta -> Eq
| `Bg_bright_magenta, _ -> Lt
| _, `Bg_bright_magenta -> Gt
| `Bg_bright_cyan, `Bg_bright_cyan -> Eq
| `Bg_bright_cyan, _ -> Lt
| _, `Bg_bright_cyan -> Gt
| `Bg_bright_white, `Bg_bright_white -> Eq
| `Bg_bright_white, _ -> Lt
| _, `Bg_bright_white -> Gt
| `Bg_8_bit_color c1, `Bg_8_bit_color c2 -> RGB8.compare c1 c2
| `Bg_8_bit_color _, _ -> Lt
| _, `Bg_8_bit_color _ -> Gt
| `Bg_24_bit_color c1, `Bg_24_bit_color c2 -> RGB24.compare c1 c2
| `Bg_24_bit_color _, _ -> Lt
| _, `Bg_24_bit_color _ -> Gt
| `Bold, `Bold -> Eq
| `Bold, _ -> Lt
| _, `Bold -> Gt
| `Dim, `Dim -> Eq
| `Dim, _ -> Lt
| _, `Dim -> Gt
| `Italic, `Italic -> Eq
| `Italic, _ -> Lt
| _, `Italic -> Gt
| `Underline, `Underline -> Eq
;;
module Of_ansi_code = struct
type code = t
type nonrec t =
[ `Clear
| `Unknown
| code
]
let write_to_buffer (buf : Buffer.t) = function
| `Clear -> Buffer.add_char buf '0'
| `Unknown -> Buffer.add_char buf '0'
| #code as t -> write_to_buffer buf (t :> code)
;;
end
let of_ansi_code : int -> Of_ansi_code.t = function
| 39 -> `Fg_default
| 30 -> `Fg_black
| 31 -> `Fg_red
| 32 -> `Fg_green
| 33 -> `Fg_yellow
| 34 -> `Fg_blue
| 35 -> `Fg_magenta
| 36 -> `Fg_cyan
| 37 -> `Fg_white
| 90 -> `Fg_bright_black
| 91 -> `Fg_bright_red
| 92 -> `Fg_bright_green
| 93 -> `Fg_bright_yellow
| 94 -> `Fg_bright_blue
| 95 -> `Fg_bright_magenta
| 96 -> `Fg_bright_cyan
| 97 -> `Fg_bright_white
| 49 -> `Bg_default
| 40 -> `Bg_black
| 41 -> `Bg_red
| 42 -> `Bg_green
| 43 -> `Bg_yellow
| 44 -> `Bg_blue
| 45 -> `Bg_magenta
| 46 -> `Bg_cyan
| 47 -> `Bg_white
| 100 -> `Bg_bright_black
| 101 -> `Bg_bright_red
| 102 -> `Bg_bright_green
| 103 -> `Bg_bright_yellow
| 104 -> `Bg_bright_blue
| 105 -> `Bg_bright_magenta
| 106 -> `Bg_bright_cyan
| 107 -> `Bg_bright_white
| 1 -> `Bold
| 2 -> `Dim
| 3 -> `Italic
| 4 -> `Underline
| 0 -> `Clear
| _ -> `Unknown
;;
let is_not_fg = function
| `Fg_default
| `Fg_black
| `Fg_red
| `Fg_green
| `Fg_yellow
| `Fg_blue
| `Fg_magenta
| `Fg_cyan
| `Fg_white
| `Fg_bright_black
| `Fg_bright_red
| `Fg_bright_green
| `Fg_bright_yellow
| `Fg_bright_blue
| `Fg_bright_magenta
| `Fg_bright_cyan
| `Fg_bright_white
| `Fg_8_bit_color _
| `Fg_24_bit_color _ -> false
| _ -> true
;;
let is_not_bg = function
| `Bg_default
| `Bg_black
| `Bg_red
| `Bg_green
| `Bg_yellow
| `Bg_blue
| `Bg_magenta
| `Bg_cyan
| `Bg_white
| `Bg_bright_black
| `Bg_bright_red
| `Bg_bright_green
| `Bg_bright_yellow
| `Bg_bright_blue
| `Bg_bright_magenta
| `Bg_bright_cyan
| `Bg_bright_white
| `Bg_8_bit_color _
| `Bg_24_bit_color _ -> false
| _ -> true
;;
let rec write_codes buf = function
| [] -> ()
| [ t ] -> Of_ansi_code.write_to_buffer buf t
| t :: ts ->
Of_ansi_code.write_to_buffer buf t;
Buffer.add_char buf ';';
write_codes buf ts
;;
let escape_sequence_no_reset buf l =
Buffer.add_string buf "\027[";
write_codes buf l;
Buffer.add_char buf 'm';
let res = Buffer.contents buf in
Buffer.clear buf;
res
;;
let escape_sequence_buf buf l =
escape_sequence_no_reset buf (`Clear :: (l :> Of_ansi_code.t list))
;;
let escape_sequence (l : t list) =
escape_sequence_buf (Buffer.create 16) (l :> Of_ansi_code.t list)
;;
end
let supports_color isatty =
let is_smart =
match Env.(get initial) "TERM" with
| Some "dumb" -> false
| _ -> true
and clicolor =
match Env.(get initial) "CLICOLOR" with
| Some "0" -> false
| _ -> true
and clicolor_force =
match Env.(get initial) "CLICOLOR_FORCE" with
| None | Some "0" -> false
| _ -> true
in
clicolor_force || (is_smart && clicolor && Lazy.force isatty)
;;
let stdout_supports_color = lazy (supports_color (lazy (Unix.isatty Unix.stdout)))
let output_is_a_tty = lazy (Unix.isatty Unix.stderr)
let stderr_supports_color = lazy (supports_color output_is_a_tty)
let rec tag_handler buf current_styles ppf (styles : Style.t list) pp =
Format.pp_print_as
ppf
0
(Style.escape_sequence_no_reset buf (styles :> Style.Of_ansi_code.t list));
Pp.to_fmt_with_tags ppf pp ~tag_handler:(tag_handler buf (current_styles @ styles));
Format.pp_print_as
ppf
0
(Style.escape_sequence_buf buf (current_styles :> Style.t list))
;;
let skip_line_break =
lazy
(match Sys.getenv_opt "DUNE_CONFIG__SKIP_LINE_BREAK" with
| Some "enabled" -> true
| _ -> false)
;;
let make_printer supports_color ppf =
let f =
lazy
(if Lazy.force supports_color
then (
let buf = Buffer.create 16 in
Pp.to_fmt_with_tags ppf ~tag_handler:(tag_handler buf []))
else Pp.to_fmt ppf)
in
Staged.stage (fun pp ->
if Lazy.force skip_line_break then Format.pp_set_margin ppf Format.pp_infinity;
Lazy.force f pp;
Format.pp_print_flush ppf ())
;;
let print = Staged.unstage (make_printer stdout_supports_color Format.std_formatter)
let prerr = Staged.unstage (make_printer stderr_supports_color Format.err_formatter)
let strip str =
let len = String.length str in
let buf = Buffer.create len in
let rec loop start i =
if i = len
then (
if i - start > 0 then Buffer.add_substring buf str start (i - start);
Buffer.contents buf)
else (
match String.unsafe_get str i with
| '\027' ->
if i - start > 0 then Buffer.add_substring buf str start (i - start);
skip (i + 1)
| _ -> loop start (i + 1))
and skip i =
if i = len
then Buffer.contents buf
else (
match String.unsafe_get str i with
| 'm' -> loop (i + 1) (i + 1)
| _ -> skip (i + 1))
in
loop 0 0
;;
let index_from_any str start chars =
let n = String.length str in
let rec go i =
if i >= n
then None
else (
match List.find chars ~f:(fun c -> Char.equal str.[i] c) with
| None -> go (i + 1)
| Some c -> Some (i, c))
in
go start
;;
let rec parse_styles l (accu : Style.t list) =
(* This function takes a list of strings, taken from splitting an Ansi code on
';', and adds the parsed styles to the already accumulated styles. There is
some non-trivial interaction with parsing here. For example, 8-bit and
24-bit color codes need some lookahead and default colours need to be able
to override other styles. *)
match l with
| [] -> accu (* Parsing 8-bit foreground colors *)
| "38" :: "5" :: s :: l ->
parse_styles
l
(match Int.of_string s with
| None -> accu
| Some code -> `Fg_8_bit_color (RGB8.of_int code) :: accu)
(* Parsing 8-bit background colors *)
| "48" :: "5" :: s :: l ->
parse_styles
l
(match Int.of_string s with
| None -> accu
| Some code -> `Bg_8_bit_color (RGB8.of_int code) :: accu)
(* Parsing 24-bit foreground colors *)
| "38" :: "2" :: r :: g :: b :: l ->
parse_styles
l
(match Int.of_string r, Int.of_string g, Int.of_string b with
| Some red, Some green, Some blue ->
`Fg_24_bit_color (RGB24.make ~red ~green ~blue) :: accu
| _ -> accu)
(* Parsing 24-bit background colors *)
| "48" :: "2" :: r :: g :: b :: l ->
parse_styles
l
(match Int.of_string r, Int.of_string g, Int.of_string b with
| Some red, Some green, Some blue ->
`Bg_24_bit_color (RGB24.make ~red ~green ~blue) :: accu
| _ -> accu)
| s :: l ->
parse_styles
l
(match Int.of_string s with
| None -> accu
| Some code ->
(match Style.of_ansi_code code with
| `Clear -> []
| `Unknown -> accu
(* If the foreground is set to default, we filter out any
other foreground modifiers. Same for background. *)
| `Fg_default -> List.filter accu ~f:Style.is_not_fg
| `Bg_default -> List.filter accu ~f:Style.is_not_bg
| #Style.t as s -> s :: accu))
;;
let parse_styles styles l = parse_styles l (List.rev styles) |> List.rev
let parse_line str styles =
let len = String.length str in
let add_chunk acc ~styles ~pos ~len =
if len = 0
then acc
else (
let s = Pp.verbatim (String.sub str ~pos ~len) in
let s =
match styles with
| [] -> s
| _ -> Pp.tag styles s
in
Pp.seq acc s)
in
let rec loop (styles : Style.t list) i acc =
match String.index_from str i '\027' with
| None -> styles, add_chunk acc ~styles ~pos:i ~len:(len - i)
| Some seq_start ->
let acc = add_chunk acc ~styles ~pos:i ~len:(seq_start - i) in
(* Skip the "\027[" *)
let seq_start = seq_start + 2 in
if seq_start >= len || str.[seq_start - 1] <> '['
then styles, acc
else (
match index_from_any str seq_start [ 'm'; 'K' ] with
| None -> styles, acc
| Some (seq_end, 'm') ->
let styles =
if seq_start = seq_end
then
(* Some commands output "\027[m", which seems to be interpreted
the same as "\027[0m" by terminals *)
[]
else
String.sub str ~pos:seq_start ~len:(seq_end - seq_start)
|> String.split ~on:';'
|> parse_styles styles
in
loop styles (seq_end + 1) acc
| Some (seq_end, _) -> loop styles (seq_end + 1) acc)
in
loop styles 0 Pp.nop
;;
let parse =
let rec loop styles lines acc =
match lines with
| [] -> Pp.vbox (Pp.concat ~sep:Pp.cut (List.rev acc))
| line :: lines ->
let styles, pp = parse_line line styles in
loop styles lines (pp :: acc)
in
fun str -> loop [] (String.split_lines str) []
;;

115
unikernel/duniverse/dune_/otherlibs/stdune/src/ansi_color.mli Normal file
View file

@ -0,0 +1,115 @@
module RGB8 : sig
(** 8 bit RGB color *)
type t
(** [RGB8.to_int t] returns the [int] value of [t] as an 8 bit integer. *)
val to_int : t -> int
(** [RGB8.of_int i] creates an [RGB8.t] from an [int] considered as an 8 bit integer.
The first 24 bits are discarded. *)
val of_int : int -> t
(** [RGB8.of_char c] creates an [RGB8.t] from a [char] considered as an 8 bit integer. *)
val of_char : char -> t
(** [RGB8.to_char t] returns the [char] value of [t] considered as an 8 bit integer. *)
val to_char : t -> char
end
module RGB24 : sig
(** 24 bit RGB color *)
type t
(** [RGB24.red t] returns the red component of [t] *)
val red : t -> int
(** [RGB24.green t] returns the green component of [t] *)
val green : t -> int
(** [RGB24.blue t] returns the blue component of [t] *)
val blue : t -> int
(** [RGB24.make ~red ~green ~blue] creates an [RGB24.t] from the given components *)
val make : red:int -> green:int -> blue:int -> t
(** [RGB24.to_int t] returns the [int] value of [t] as a 24 bit integer. *)
val to_int : t -> int
(** [RGB24.of_int i] creates an [RGB24.t] from an [int] considered as a 24 bit integer.
The first 8 bits are discarded. *)
val of_int : int -> t
end
module Style : sig
(** ANSI terminal styles *)
type t =
[ `Fg_default
| `Fg_black
| `Fg_red
| `Fg_green
| `Fg_yellow
| `Fg_blue
| `Fg_magenta
| `Fg_cyan
| `Fg_white
| `Fg_bright_black
| `Fg_bright_red
| `Fg_bright_green
| `Fg_bright_yellow
| `Fg_bright_blue
| `Fg_bright_magenta
| `Fg_bright_cyan
| `Fg_bright_white
| `Fg_8_bit_color of RGB8.t
| `Fg_24_bit_color of RGB24.t
| `Bg_default
| `Bg_black
| `Bg_red
| `Bg_green
| `Bg_yellow
| `Bg_blue
| `Bg_magenta
| `Bg_cyan
| `Bg_white
| `Bg_bright_black
| `Bg_bright_red
| `Bg_bright_green
| `Bg_bright_yellow
| `Bg_bright_blue
| `Bg_bright_magenta
| `Bg_bright_cyan
| `Bg_bright_white
| `Bg_8_bit_color of RGB8.t
| `Bg_24_bit_color of RGB24.t
| `Bold
| `Dim
| `Italic
| `Underline
]
val to_dyn : t -> Dyn.t
val compare : t -> t -> Ordering.t
(** Ansi escape sequence that set the terminal style to exactly these styles *)
val escape_sequence : t list -> string
end
val make_printer : bool Lazy.t -> Format.formatter -> (Style.t list Pp.t -> unit) Staged.t
(** Print to [Format.std_formatter] *)
val print : Style.t list Pp.t -> unit
(** Print to [Format.err_formatter] *)
val prerr : Style.t list Pp.t -> unit
(** Whether [stdout]/[stderr] support colors *)
val stdout_supports_color : bool Lazy.t
val stderr_supports_color : bool Lazy.t
val output_is_a_tty : bool Lazy.t
(** Filter out escape sequences in a string *)
val strip : string -> string
(** Parse a string containing ANSI escape sequences *)
val parse : string -> Style.t list Pp.t

54
unikernel/duniverse/dune_/otherlibs/stdune/src/appendable_list.ml Normal file
View file

@ -0,0 +1,54 @@
type 'a t =
| Empty
| Singleton of 'a
| Cons of 'a * 'a t
| List of 'a list
| Append of 'a t * 'a t
| Concat of 'a t list
let empty = Empty
let singleton x = Singleton x
let ( @ ) a b =
match a, b with
| Empty, _ -> b
| _, Empty -> a
| Singleton a, _ -> Cons (a, b)
| _, _ -> Append (a, b)
;;
let cons x xs = Cons (x, xs)
let to_list_rev =
let rec loop1 acc t stack =
match t with
| Empty -> loop0 acc stack
| Singleton x -> loop0 (x :: acc) stack
| Cons (x, xs) -> loop1 (x :: acc) xs stack
| List xs -> loop0 (List.rev_append xs acc) stack
| Append (xs, ys) -> loop1 acc xs (ys :: stack)
| Concat [] -> loop0 acc stack
| Concat (x :: xs) -> loop1 acc x (Concat xs :: stack)
and loop0 acc stack =
match stack with
| [] -> acc
| t :: stack -> loop1 acc t stack
in
fun t -> loop1 [] t []
;;
let to_list xs = List.rev (to_list_rev xs)
let rec is_empty = function
| List (_ :: _) | Singleton _ | Cons _ -> false
| Append (x, y) -> is_empty x && is_empty y
| Concat xs -> is_empty_list xs
| List [] | Empty -> true
and is_empty_list = function
| [] -> true
| x :: xs -> is_empty x && is_empty_list xs
;;
let concat list = Concat list
let of_list x = List x

16
unikernel/duniverse/dune_/otherlibs/stdune/src/appendable_list.mli Normal file
View file

@ -0,0 +1,16 @@
(** Appendable lists: concatenation takes O(1) time, conversion to a list takes
O(n). *)
type 'a t
val empty : 'a t
val singleton : 'a -> 'a t
val ( @ ) : 'a t -> 'a t -> 'a t
val cons : 'a -> 'a t -> 'a t
val to_list : 'a t -> 'a list
val to_list_rev : 'a t -> 'a list
val of_list : 'a list -> 'a t
val concat : 'a t list -> 'a t
(** The current implementation is slow, don't use it on a hot path. *)
val is_empty : _ t -> bool

39
unikernel/duniverse/dune_/otherlibs/stdune/src/applicative.ml Normal file
View file

@ -0,0 +1,39 @@
module type Basic = Applicative_intf.Basic
module Make (A : Applicative_intf.Basic) = struct
include A
module O = struct
let ( let+ ) x f = A.map x ~f
let ( and+ ) = A.both
let ( >>> ) x y =
let+ () = x
and+ y = y in
y
;;
end
let rec all xs =
match xs with
| [] -> return []
| x :: xs ->
let open O in
let+ x = x
and+ xs = all xs in
x :: xs
;;
end
[@@inline always]
module Id = struct
include Make (struct
type 'a t = 'a
let return a = a
let map x ~f = f x
let both x y = x, y
end)
let all x = x
end

4
unikernel/duniverse/dune_/otherlibs/stdune/src/applicative.mli Normal file
View file

@ -0,0 +1,4 @@
module type Basic = Applicative_intf.Basic
module Make (A : Basic) : Applicative_intf.S with type 'a t := 'a A.t
module Id : Applicative_intf.S with type 'a t = 'a

23
unikernel/duniverse/dune_/otherlibs/stdune/src/applicative_intf.ml Normal file
View file

@ -0,0 +1,23 @@
(** This module type is accessible as just [Stdune.Applicative.Basic] outside of
[Stdune]. *)
module type Basic = sig
type 'a t
val return : 'a -> 'a t
val map : 'a t -> f:('a -> 'b) -> 'b t
val both : 'a t -> 'b t -> ('a * 'b) t
end
(** This module type is accessible as just [Stdune.Applicative] outside of
[Stdune]. *)
module type S = sig
include Basic
val all : 'a t list -> 'a list t
module O : sig
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
val ( >>> ) : unit t -> 'a t -> 'a t
end
end

79
unikernel/duniverse/dune_/otherlibs/stdune/src/array.ml Normal file
View file

@ -0,0 +1,79 @@
module Array = Stdlib.Array
include struct
exception Found of int
[@@@ocaml.warning "-32"]
let find_opt ~f t =
try
for i = 0 to Array.length t do
if f t.(i) then raise_notrace (Found i)
done;
None
with
| Found i -> Some t.(i)
;;
end
let swap arr i j =
let first, second = arr.(i), arr.(j) in
arr.(i) <- second;
arr.(j) <- first
;;
module T = struct
include ArrayLabels
let equal f x y =
let open Stdlib.Array in
let len = length x in
if len <> length y
then false
else (
try
for i = 0 to len - 1 do
if not (f (get x i) (get y i)) then raise_notrace Exit
done;
true
with
| Exit -> false)
;;
let to_dyn f t = Dyn.array f t
let map t ~f = map t ~f
let fold_right t ~f ~init = fold_right t ~f ~init
let exists t ~f = exists t ~f
end
include T
let to_list_map =
let rec loop arr i f acc =
if i < 0
then acc
else (
let acc = f (get arr i) :: acc in
loop arr (i - 1) f acc)
in
fun arr ~f -> loop arr (length arr - 1) f []
;;
let of_list_map l ~f =
let len = List.length l in
let l = ref l in
init len ~f:(fun _ ->
match !l with
| [] -> assert false
| x :: xs ->
l := xs;
f x)
;;
module Immutable = struct
include T
let of_array a = copy a
let to_list_map t ~f = to_list_map t ~f
let of_list_map t ~f = of_list_map t ~f
end

25
unikernel/duniverse/dune_/otherlibs/stdune/src/array.mli Normal file
View file

@ -0,0 +1,25 @@
include module type of Stdlib.ArrayLabels with type 'a t = 'a array
val find_opt : f:('a -> bool) -> 'a t -> 'a option
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val map : 'a t -> f:('a -> 'b) -> 'b t
val exists : 'a t -> f:('a -> bool) -> bool
val fold_right : 'a t -> f:('a -> 'acc -> 'acc) -> init:'acc -> 'acc
val swap : 'a t -> int -> int -> unit
module Immutable : sig
type 'a t
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val get : 'a t -> int -> 'a
val of_array : 'a array -> 'a t
val to_list : 'a t -> 'a list
val of_list : 'a list -> 'a t
val map : 'a t -> f:('a -> 'b) -> 'b t
val to_dyn : ('a -> Dyn.t) -> 'a t -> Dyn.t
val fold_right : 'a t -> f:('a -> 'acc -> 'acc) -> init:'acc -> 'acc
val exists : 'a t -> f:('a -> bool) -> bool
val length : _ t -> int
val to_list_map : 'a t -> f:('a -> 'b) -> 'b list
val of_list_map : 'a list -> f:('a -> 'b) -> 'b t
end

38
unikernel/duniverse/dune_/otherlibs/stdune/src/bin.ml Normal file
View file

@ -0,0 +1,38 @@
let path_sep = if Sys.win32 then ';' else ':'
let parse ?(sep = path_sep) s = String.split s ~on:sep
let parse_path ?(sep = path_sep) s =
parse ~sep s
|> List.filter_map ~f:(function
| "" -> None
| p -> Some (Path.of_filename_relative_to_initial_cwd p))
;;
let encode_strings paths = String.concat ~sep:(String.make 1 path_sep) paths
let cons_path ?(path_sep = path_sep) p ~_PATH =
let p = Path.to_absolute_filename p in
match _PATH with
| None -> p
| Some s -> Printf.sprintf "%s%c%s" p path_sep s
;;
let exe = if Sys.win32 then ".exe" else ""
let exists fn =
match Unix.stat (Path.to_string fn) with
| { st_kind = S_DIR; _ } -> false
| exception Unix.Unix_error _ -> false
| _ -> true
;;
let add_exe prog =
if String.is_suffix (String.lowercase prog) ~suffix:exe then prog else prog ^ exe
;;
let which ~path prog =
let prog = add_exe prog in
List.find_map path ~f:(fun dir ->
let fn = Path.relative dir prog in
Option.some_if (exists fn) fn)
;;

30
unikernel/duniverse/dune_/otherlibs/stdune/src/bin.mli Normal file
View file

@ -0,0 +1,30 @@
(** Binaries from the PATH *)
(** Character used to separate entries in [PATH] and similar environment
variables *)
val path_sep : char
(** Parse a [PATH] like variable *)
val parse : ?sep:char -> string -> string list
(** Parse a [PATH] like variable expecting each element to be a path *)
val parse_path : ?sep:char -> string -> Path.t list
(** Return a delimited string encoding of a list of strings, such as
is used by the [PATH] variable *)
val encode_strings : string list -> string
(** Add an entry to the contents of a [PATH] variable. *)
val cons_path : ?path_sep:char -> Path.t -> _PATH:string option -> string
(** Extension to append to executable filenames *)
val exe : string
(** Adds an [.exe] suffix unless it is already present *)
val add_exe : string -> string
(** Check if a file exists *)
val exists : Path.t -> bool
(** Look for a program in the PATH *)
val which : path:Path.t list -> string -> Path.t option

55
unikernel/duniverse/dune_/otherlibs/stdune/src/bit_set.ml Normal file
View file

@ -0,0 +1,55 @@
module Common = struct
(* All of these values are the same regardless of the instantiation of the
functor. That is to say, they're independent of the representation of
elements *)
let empty = 0
let union = ( lor )
let inter = ( land )
let equal = Int.equal
let compare = Int.compare
end
module Make (Element : sig
type t
val to_int : t -> int
val all : t list
val to_dyn : t -> Dyn.t
end) =
struct
type t = int
include Common
let () =
assert (List.length Element.all < Sys.int_size);
let (_ : unit Int.Map.t) =
Int.Map.of_list_map_exn Element.all ~f:(fun x ->
let x = Element.to_int x in
assert (x >= 0 && x < Sys.int_size);
x, ())
in
()
;;
let singleton x = 1 lsl Element.to_int x
let add t x = union t (singleton x)
let mem t x = t land singleton x <> empty
let to_dyn t : Dyn.t =
Set
(List.fold_left Element.all ~init:[] ~f:(fun acc x ->
if mem t x then Element.to_dyn x :: acc else acc))
;;
let of_func =
let all = Array.of_list Element.all in
fun f ->
let acc = ref empty in
for i = 0 to Array.length all - 1 do
if f all.(i) then acc := union !acc (singleton all.(i))
done;
!acc
;;
end

27
unikernel/duniverse/dune_/otherlibs/stdune/src/bit_set.mli Normal file
View file

@ -0,0 +1,27 @@
(** A set of elements that can be represented by a single word *)
module Make (Element : sig
type t
(** [to_int t] must return a unique number for every [t] between [0] and
[Sys.int_size - 1] (inclusive) *)
val to_int : t -> int
(** [all] contains all possible set elements *)
val all : t list
val to_dyn : t -> Dyn.t
end) : sig
type t [@@immediate]
val empty : t
val singleton : Element.t -> t
val add : t -> Element.t -> t
val inter : t -> t -> t
val union : t -> t -> t
val mem : t -> Element.t -> bool
val to_dyn : t -> Dyn.t
val compare : t -> t -> Ordering.t
val equal : t -> t -> bool
val of_func : (Element.t -> bool) -> t
end

21
unikernel/duniverse/dune_/otherlibs/stdune/src/bool.ml Normal file
View file

@ -0,0 +1,21 @@
let compare x y =
match x, y with
| true, true | false, false -> Ordering.Eq
| true, false -> Gt
| false, true -> Lt
;;
include Comparator.Operators (struct
type nonrec t = bool
let compare = compare
end)
let to_string = string_of_bool
let of_string s = bool_of_string_opt s
let to_dyn t = Dyn.Bool t
let[@inline always] hash = function
| true -> 1
| false -> 0
;;

10
unikernel/duniverse/dune_/otherlibs/stdune/src/bool.mli Normal file
View file

@ -0,0 +1,10 @@
type t = bool
val compare : t -> t -> Ordering.t
include Comparator.OPS with type t := t
val to_string : t -> string
val of_string : string -> t option
val to_dyn : t -> Dyn.t
val hash : t -> int

1
unikernel/duniverse/dune_/otherlibs/stdune/src/bytes.ml Normal file
View file

@ -0,0 +1 @@
include StdLabels.Bytes

3
unikernel/duniverse/dune_/otherlibs/stdune/src/bytes.mli Normal file
View file

@ -0,0 +1,3 @@
include module type of struct
include StdLabels.Bytes
end

53
unikernel/duniverse/dune_/otherlibs/stdune/src/bytes_unit.ml Normal file
View file

@ -0,0 +1,53 @@
let bytes_conversion_table = [ [ "B"; "bytes" ], 1L ]
let rec long_power (l : int64) (n : int) : int64 =
if n = 0 then 1L else Int64.mul l @@ long_power l (n - 1)
;;
let decimal_conversion_table =
[ [ "kB"; "KB"; "kilobytes" ], 1_000L
; [ "MB"; "megabytes" ], long_power 1_000L 2
; [ "GB"; "gigabytes" ], long_power 1_000L 3
; [ "TB"; "terabytes" ], long_power 1_000L 4
]
;;
let binary_conversion_table =
[ [ "KiB"; "KiB"; "kibibytes" ], 1024L
; [ "MiB"; "mebibytes" ], long_power 1024L 2
; [ "GiB"; "gibibytes" ], long_power 1024L 3
; [ "TiB"; "tebibytes" ], long_power 1024L 4
]
;;
(* When printing we only use this conversion table *)
let conversion_table = bytes_conversion_table @ decimal_conversion_table
let pp x =
(* We go through the list to find the first unit that is greater than the
number of bytes and take the predecessor as the units for printing. For the
special base case where no conversion is necessary we don't print as a
float. *)
let suffix, value =
let rec loop = function
| [] -> assert false
| [ (units, value) ] -> List.hd units, value
| (units, value) :: ((_, value') :: _ as l) ->
if x = 0L
then List.hd units, value
else if value <= x && x < value'
then List.hd units, value
else loop l
in
loop @@ conversion_table
in
if value = 1L
then Printf.sprintf "%Ld%s" x suffix
else Printf.sprintf "%.2f%s" (Int64.to_float x /. Int64.to_float value) suffix
;;
(* When parsing we accept all units *)
let conversion_table =
bytes_conversion_table @ decimal_conversion_table @ binary_conversion_table
|> List.sort ~compare:(fun (_, x) (_, y) -> Ordering.of_int @@ Int64.compare x y)
;;

8
unikernel/duniverse/dune_/otherlibs/stdune/src/bytes_unit.mli Normal file
View file

@ -0,0 +1,8 @@
(** Conversion table for decimal byte suffixes and their corresponding [Int64.t] values.
The first element of the tuple is a list of possible suffixes for the second element
of the tuple which is the value. There are some static checks done on this table
ensuring it is ordered and well-formed.*)
val conversion_table : (string list * Int64.t) list
(** [pp n] pretty-prints [n] as a decimal byte suffix. *)
val pp : Int64.t -> string

32
unikernel/duniverse/dune_/otherlibs/stdune/src/caller_id.ml Normal file
View file

@ -0,0 +1,32 @@
(* Small helper to find out who is the caller of a function *)
let get ~skip =
let skip = __FILE__ :: skip in
let stack = Printexc.get_callstack 16 in
let len = Printexc.raw_backtrace_length stack in
let rec loop pos =
if pos = len
then None
else (
match
Printexc.get_raw_backtrace_slot stack pos
|> Printexc.convert_raw_backtrace_slot
|> Printexc.Slot.location
with
| None -> None
| Some loc ->
if List.mem skip loc.filename ~equal:String.equal
then loop (pos + 1)
else (
let start : Lexing.position =
{ pos_fname = loc.filename
; pos_lnum = loc.line_number
; pos_bol = 0
; pos_cnum = loc.start_char
}
in
let stop = { start with pos_cnum = loc.end_char } in
Some (Loc.create ~start ~stop)))
in
loop 0
;;

6
unikernel/duniverse/dune_/otherlibs/stdune/src/caller_id.mli Normal file
View file

@ -0,0 +1,6 @@
(** Who called me? *)
(** [get ~skip] returns the first element of the call stack that is not in
[skip]. For instance, [get ~skip:[__FILE__]] will return the first call site
outside of the current file. *)
val get : skip:string list -> Loc.t option

14
unikernel/duniverse/dune_/otherlibs/stdune/src/char.ml Normal file
View file

@ -0,0 +1,14 @@
include Stdlib.Char
let is_digit = function
| '0' .. '9' -> true
| _non_digit_char -> false
;;
let is_lowercase_hex = function
| '0' .. '9' | 'a' .. 'f' -> true
| _non_lowercase_hex_char -> false
;;
let[@inline always] hash c = Int.hash (code c)
let compare x y = Ordering.of_int (compare x y)

12
unikernel/duniverse/dune_/otherlibs/stdune/src/char.mli Normal file
View file

@ -0,0 +1,12 @@
include module type of struct
include Stdlib.Char
end
(** Check if a character belongs to the set [{'0'..'9'}]. *)
val is_digit : t -> bool
(** Check if a character belongs to the set [{'0'..'9', 'a'..'f'}]. *)
val is_lowercase_hex : t -> bool
val hash : t -> int
val compare : t -> t -> Ordering.t

32
unikernel/duniverse/dune_/otherlibs/stdune/src/code_error.ml Normal file
View file

@ -0,0 +1,32 @@
type t =
{ message : string
; data : (string * Dyn.t) list
; loc : Loc0.t option
}
exception E of t
let create ?loc message data = { message; data; loc }
let raise ?loc message data = raise (E { message; data; loc })
let dyn_fields_without_loc { loc = _; message; data } =
[ Dyn.String message; Record data ]
;;
let to_dyn_without_loc t : Dyn.t = Tuple (dyn_fields_without_loc t)
let to_dyn t : Dyn.t =
let fields = dyn_fields_without_loc t in
let fields =
match t.loc with
| None -> fields
| Some loc -> Loc0.to_dyn loc :: fields
in
Tuple fields
;;
let () =
Printexc.register_printer (function
| E t -> Some (Dyn.to_string (to_dyn t))
| _ -> None)
;;

14
unikernel/duniverse/dune_/otherlibs/stdune/src/code_error.mli Normal file
View file

@ -0,0 +1,14 @@
(** A programming error that should be reported upstream *)
type t =
{ message : string
; data : (string * Dyn.t) list
; loc : Loc0.t option
}
exception E of t
val to_dyn_without_loc : t -> Dyn.t
val to_dyn : t -> Dyn.t
val create : ?loc:Loc0.t -> string -> (string * Dyn.t) list -> t
val raise : ?loc:Loc0.t -> string -> (string * Dyn.t) list -> _

141
unikernel/duniverse/dune_/otherlibs/stdune/src/compact_position.ml Normal file
View file

@ -0,0 +1,141 @@
module Position = struct
(* We encode the position in three, 21 bit fields: [cnum][lnum][bol] *)
type t = int
let field_size = 21
let field_mask = (1 lsl field_size) - 1
let shift_bol = 0
let shift_lnum = field_size
let shift_cnum = 2 * field_size
let small_enough =
let max_size = 1 lsl field_size in
let test int = int <= max_size in
fun [@inline] { Lexing.pos_bol; pos_cnum; pos_lnum; pos_fname = _ } ->
test pos_bol && test pos_cnum && test pos_lnum
;;
let[@inline] of_position { Lexing.pos_bol; pos_cnum; pos_lnum; pos_fname = _ } =
((pos_bol land field_mask) lsl shift_bol)
lor ((pos_lnum land field_mask) lsl shift_lnum)
lor ((pos_cnum land field_mask) lsl shift_cnum)
;;
let[@inline] bol t = (t lsr shift_bol) land field_mask
let[@inline] lnum t = (t lsr shift_lnum) land field_mask
let[@inline] cnum t = (t lsr shift_cnum) land field_mask
let to_position t ~fname:pos_fname =
let pos_bol = bol t in
let pos_cnum = cnum t in
let pos_lnum = lnum t in
{ Lexing.pos_bol; pos_cnum; pos_lnum; pos_fname }
;;
end
module Same_line_loc = struct
(* we encode the location in four, 15 bit chunks
[bol][lnum][start_cnum][stop_cnum]
Note that this leaves us with 3 spare bits. We should probably use them to
expand [bol] and [lnum] a little.
CR-someday jtov: Instead of [stop_cnum], we can store [stop_cnum -
start_cnum]. This should be smaller than [stop_cnum] and release more
bits for other fields.
*)
type t = int
let field_size = 15
let field_mask = (1 lsl field_size) - 1
let shift_bol = 0
let shift_lnum = field_size
let shift_start_cnum = 2 * field_size
let shift_stop_cnum = 3 * field_size
let create ~bol ~lnum ~start_cnum ~stop_cnum =
((bol land field_mask) lsl shift_bol)
lor ((lnum land field_mask) lsl shift_lnum)
lor ((start_cnum land field_mask) lsl shift_start_cnum)
lor ((stop_cnum land field_mask) lsl shift_stop_cnum)
;;
let[@inline] bol t = (t lsr shift_bol) land field_mask
let[@inline] lnum t = (t lsr shift_lnum) land field_mask
let[@inline] start_cnum t = (t lsr shift_start_cnum) land field_mask
let[@inline] stop_cnum t = (t lsr shift_stop_cnum) land field_mask
let set_start_to_stop t =
let bol = bol t in
let lnum = lnum t in
let stop_cnum = stop_cnum t in
(* this can be optimized more if necessary *)
create ~bol ~lnum ~start_cnum:stop_cnum ~stop_cnum
;;
let small_enough =
let max_size = 1 lsl field_size in
fun [@inline] int -> int <= max_size
;;
let[@inline] to_loc t ~fname:pos_fname =
let pos_lnum = lnum t in
let pos_bol = bol t in
let start = { Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = start_cnum t } in
let stop = { start with pos_cnum = stop_cnum t } in
{ Lexbuf.Loc.start; stop }
;;
let[@inline] start t ~fname:pos_fname =
let pos_lnum = lnum t in
let pos_bol = bol t in
{ Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = start_cnum t }
;;
let[@inline] stop t ~fname:pos_fname =
let pos_lnum = lnum t in
let pos_bol = bol t in
{ Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = stop_cnum t }
;;
end
include Position
type of_loc =
| Same_line of Same_line_loc.t
| Loc of
{ start : t
; stop : t
}
| Loc_does_not_fit
let[@inline] try_loc { Lexbuf.Loc.start; stop } =
if Position.small_enough start && Position.small_enough stop
then (
let start = Position.of_position start in
let stop = Position.of_position stop in
Loc { start; stop })
else Loc_does_not_fit
;;
let[@inline] of_loc ({ Lexbuf.Loc.start; stop } as loc) =
if start.pos_fname <> stop.pos_fname
then Loc_does_not_fit
else if start.pos_bol = stop.pos_bol && start.pos_lnum = stop.pos_lnum
then (
let bol = start.pos_bol in
let lnum = start.pos_lnum in
let start_cnum = start.pos_cnum in
let stop_cnum = stop.pos_cnum in
let test = Same_line_loc.small_enough in
if test bol && test lnum && test start_cnum && test stop_cnum
then Same_line (Same_line_loc.create ~bol ~lnum ~start_cnum ~stop_cnum)
else try_loc loc)
else try_loc loc
;;
let of_loc = if Sys.int_size = 63 then of_loc else fun _ -> Loc_does_not_fit
module For_tests = struct
let small_enough = small_enough
end

36
unikernel/duniverse/dune_/otherlibs/stdune/src/compact_position.mli Normal file
View file

@ -0,0 +1,36 @@
(** Positions information that can be encoded within a single immediate *)
type t [@@immediate]
val of_position : Lexbuf.Position.t -> t
val to_position : t -> fname:string -> Lexbuf.Position.t
val lnum : t -> int
val cnum : t -> int
val bol : t -> int
module Same_line_loc : sig
type t [@@immediate]
val lnum : t -> int
val bol : t -> int
val start_cnum : t -> int
val stop_cnum : t -> int
val to_loc : t -> fname:string -> Lexbuf.Loc.t
val start : t -> fname:string -> Lexbuf.Position.t
val stop : t -> fname:string -> Lexbuf.Position.t
val set_start_to_stop : t -> t
end
type of_loc =
| Same_line of Same_line_loc.t
| Loc of
{ start : t
; stop : t
}
| Loc_does_not_fit
val of_loc : Lexbuf.Loc.t -> of_loc
module For_tests : sig
val small_enough : Lexbuf.Position.t -> bool
end

4
unikernel/duniverse/dune_/otherlibs/stdune/src/comparable.ml Normal file
View file

@ -0,0 +1,4 @@
module Make (Key : Map.Key) = struct
module Map = Map.Make (Key)
module Set = Set.Make (Key) (Map)
end

1
unikernel/duniverse/dune_/otherlibs/stdune/src/comparable.mli Normal file
View file

@ -0,0 +1 @@
module Make (Key : Map.Key) : Comparable_intf.S with type key := Key.t

6
unikernel/duniverse/dune_/otherlibs/stdune/src/comparable_intf.ml Normal file
View file

@ -0,0 +1,6 @@
module type S = sig
type key
module Map : Map_intf.S with type key = key
module Set : Set_intf.S with type elt = key and type 'a map = 'a Map.t
end

54
unikernel/duniverse/dune_/otherlibs/stdune/src/comparator.ml Normal file
View file

@ -0,0 +1,54 @@
module type S = sig
type t
val compare : t -> t -> Ordering.t
end
module type OPS = sig
type t
val equal : t -> t -> bool
val ( = ) : t -> t -> bool
val ( >= ) : t -> t -> bool
val ( > ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( < ) : t -> t -> bool
val ( <> ) : t -> t -> bool
end
module Operators (X : S) = struct
type t = X.t
let ( = ) a b =
match X.compare a b with
| Eq -> true
| Gt | Lt -> false
;;
let equal = ( = )
let ( <> ) a b = not (a = b)
let ( >= ) a b =
match X.compare a b with
| Gt | Eq -> true
| Lt -> false
;;
let ( > ) a b =
match X.compare a b with
| Gt -> true
| Lt | Eq -> false
;;
let ( <= ) a b =
match X.compare a b with
| Lt | Eq -> true
| Gt -> false
;;
let ( < ) a b =
match X.compare a b with
| Lt -> true
| Gt | Eq -> false
;;
end

19
unikernel/duniverse/dune_/otherlibs/stdune/src/comparator.mli Normal file
View file

@ -0,0 +1,19 @@
module type S = sig
type t
val compare : t -> t -> Ordering.t
end
module type OPS = sig
type t
val equal : t -> t -> bool
val ( = ) : t -> t -> bool
val ( >= ) : t -> t -> bool
val ( > ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( < ) : t -> t -> bool
val ( <> ) : t -> t -> bool
end
module Operators (X : S) : OPS with type t = X.t

116
unikernel/duniverse/dune_/otherlibs/stdune/src/copyfile_stubs.c Normal file
View file

@ -0,0 +1,116 @@
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#if defined(__APPLE__)
#define _DARWIN_C_SOURCE
#include <caml/alloc.h>
#include <caml/threads.h>
#include <caml/unixsupport.h>
#include <copyfile.h>
#include <errno.h>
#include <stdlib.h>
#include <string.h>
#include <sys/syslimits.h>
CAMLprim value stdune_copyfile(value v_from, value v_to) {
CAMLparam2(v_from, v_to);
caml_unix_check_path(v_from, "copyfile");
caml_unix_check_path(v_to, "copyfile");
char from[PATH_MAX];
char to[PATH_MAX];
char real_from[PATH_MAX];
int from_len = caml_string_length(v_from);
int to_len = caml_string_length(v_to);
memcpy(from, String_val(v_from), from_len);
memcpy(to, String_val(v_to), to_len);
from[from_len] = '\0';
to[to_len] = '\0';
caml_release_runtime_system();
/* clonefile doesn't follow symlinks automatically */
char *realpath_result = realpath(from, real_from);
if (realpath_result == NULL) {
caml_acquire_runtime_system();
uerror("realpath", v_from);
}
/* nor does it automatically overwrite the target */
int ret = unlink(to);
if (ret < 0 && errno != ENOENT) {
caml_acquire_runtime_system();
uerror("unlink", v_to);
}
ret = copyfile(real_from, to, NULL, COPYFILE_CLONE);
caml_acquire_runtime_system();
if (ret < 0) {
uerror("copyfile", v_to);
}
CAMLreturn(Val_unit);
}
CAMLprim value stdune_sendfile(value v_in, value v_out, value v_size) {
(void)v_in;
(void)v_out;
(void)v_size;
caml_failwith("sendfile: linux");
}
#elif __linux__
#include <caml/threads.h>
#include <caml/unixsupport.h>
#include <sys/sendfile.h>
#include <unistd.h>
#define FD_val(value) Int_val(value)
CAMLprim value stdune_copyfile(value v_from, value v_to) {
(void)v_from;
(void)v_to;
caml_failwith("copyfile: only on macos");
}
static int dune_sendfile(int in, int out, size_t length) {
ssize_t ret;
while (length > 0) {
ret = sendfile(out, in, NULL, length);
if (ret < 0) {
return ret;
}
length = length - ret;
}
return length;
}
CAMLprim value stdune_sendfile(value v_in, value v_out, value v_size) {
CAMLparam3(v_in, v_out, v_size);
caml_release_runtime_system();
/* TODO Use copy_file_range once we have a good mechanism to test for its
* existence */
int ret = dune_sendfile(FD_val(v_in), FD_val(v_out), Long_val(v_size));
caml_acquire_runtime_system();
if (ret < 0) {
uerror("sendfile", Nothing);
}
CAMLreturn(Val_unit);
}
#else
CAMLprim value stdune_sendfile(value v_in, value v_out, value v_size) {
(void)v_in;
(void)v_out;
(void)v_size;
caml_failwith("sendfile: linux");
}
CAMLprim value stdune_copyfile(value v_from, value v_to) {
(void)v_from;
(void)v_to;
caml_failwith("copyfile: only on macos");
}
#endif

5
unikernel/duniverse/dune_/otherlibs/stdune/src/dev_null.ml Normal file
View file

@ -0,0 +1,5 @@
let dev_null_fn = if Sys.win32 then "nul" else "/dev/null"
let path = Path.of_filename_relative_to_initial_cwd dev_null_fn
let open_null flags = lazy (Unix.openfile dev_null_fn flags 0o666)
let in_ = open_null [ Unix.O_RDONLY; Unix.O_CLOEXEC ]
let out = open_null [ Unix.O_WRONLY; Unix.O_CLOEXEC ]

10
unikernel/duniverse/dune_/otherlibs/stdune/src/dev_null.mli Normal file
View file

@ -0,0 +1,10 @@
(** Portable access [/dev/null] with some shared fd's to reduce the open fd
count *)
val path : Path.t
(** [path] opened in read mode. Do not close this fd. *)
val in_ : Unix.file_descr Lazy.t
(** [path] opened in write mode. Do not close this fd. *)
val out : Unix.file_descr Lazy.t

22
unikernel/duniverse/dune_/otherlibs/stdune/src/dune Normal file
View file

@ -0,0 +1,22 @@
(library
(name stdune)
(public_name stdune)
(synopsis
"Standard library of Dune.\nThis library offers no backwards compatibility guarantees. Use at your own risk.")
(libraries
unix
csexp
(re_export ordering)
(re_export dyn)
(re_export pp))
(library_flags
(:include flags/sexp))
(foreign_stubs
(language c)
(names
dune_flock
readdir
wait4_stubs
platform_stubs
copyfile_stubs
signal_stubs)))

5
unikernel/duniverse/dune_/otherlibs/stdune/src/dune_either.ml Normal file
View file

@ -0,0 +1,5 @@
module Either = struct
type ('a, 'b) t =
| Left of 'a
| Right of 'b
end

319
unikernel/duniverse/dune_/otherlibs/stdune/src/dune_filesystem_stubs.ml Normal file
View file

@ -0,0 +1,319 @@
module Unix_error = struct
type t = Unix.error
(* CR-someday amokhov: It would be nice to derive this instead. For now let's
trust I haven't messed this up. *)
let equal (x : t) (y : t) =
match x, y with
| E2BIG, E2BIG -> true
| E2BIG, _ | _, E2BIG -> false
| EACCES, EACCES -> true
| EACCES, _ | _, EACCES -> false
| EAGAIN, EAGAIN -> true
| EAGAIN, _ | _, EAGAIN -> false
| EBADF, EBADF -> true
| EBADF, _ | _, EBADF -> false
| EBUSY, EBUSY -> true
| EBUSY, _ | _, EBUSY -> false
| ECHILD, ECHILD -> true
| ECHILD, _ | _, ECHILD -> false
| EDEADLK, EDEADLK -> true
| EDEADLK, _ | _, EDEADLK -> false
| EDOM, EDOM -> true
| EDOM, _ | _, EDOM -> false
| EEXIST, EEXIST -> true
| EEXIST, _ | _, EEXIST -> false
| EFAULT, EFAULT -> true
| EFAULT, _ | _, EFAULT -> false
| EFBIG, EFBIG -> true
| EFBIG, _ | _, EFBIG -> false
| EINTR, EINTR -> true
| EINTR, _ | _, EINTR -> false
| EINVAL, EINVAL -> true
| EINVAL, _ | _, EINVAL -> false
| EIO, EIO -> true
| EIO, _ | _, EIO -> false
| EISDIR, EISDIR -> true
| EISDIR, _ | _, EISDIR -> false
| EMFILE, EMFILE -> true
| EMFILE, _ | _, EMFILE -> false
| EMLINK, EMLINK -> true
| EMLINK, _ | _, EMLINK -> false
| ENAMETOOLONG, ENAMETOOLONG -> true
| ENAMETOOLONG, _ | _, ENAMETOOLONG -> false
| ENFILE, ENFILE -> true
| ENFILE, _ | _, ENFILE -> false
| ENODEV, ENODEV -> true
| ENODEV, _ | _, ENODEV -> false
| ENOENT, ENOENT -> true
| ENOENT, _ | _, ENOENT -> false
| ENOEXEC, ENOEXEC -> true
| ENOEXEC, _ | _, ENOEXEC -> false
| ENOLCK, ENOLCK -> true
| ENOLCK, _ | _, ENOLCK -> false
| ENOMEM, ENOMEM -> true
| ENOMEM, _ | _, ENOMEM -> false
| ENOSPC, ENOSPC -> true
| ENOSPC, _ | _, ENOSPC -> false
| ENOSYS, ENOSYS -> true
| ENOSYS, _ | _, ENOSYS -> false
| ENOTDIR, ENOTDIR -> true
| ENOTDIR, _ | _, ENOTDIR -> false
| ENOTEMPTY, ENOTEMPTY -> true
| ENOTEMPTY, _ | _, ENOTEMPTY -> false
| ENOTTY, ENOTTY -> true
| ENOTTY, _ | _, ENOTTY -> false
| ENXIO, ENXIO -> true
| ENXIO, _ | _, ENXIO -> false
| EPERM, EPERM -> true
| EPERM, _ | _, EPERM -> false
| EPIPE, EPIPE -> true
| EPIPE, _ | _, EPIPE -> false
| ERANGE, ERANGE -> true
| ERANGE, _ | _, ERANGE -> false
| EROFS, EROFS -> true
| EROFS, _ | _, EROFS -> false
| ESPIPE, ESPIPE -> true
| ESPIPE, _ | _, ESPIPE -> false
| ESRCH, ESRCH -> true
| ESRCH, _ | _, ESRCH -> false
| EXDEV, EXDEV -> true
| EXDEV, _ | _, EXDEV -> false
| EWOULDBLOCK, EWOULDBLOCK -> true
| EWOULDBLOCK, _ | _, EWOULDBLOCK -> false
| EINPROGRESS, EINPROGRESS -> true
| EINPROGRESS, _ | _, EINPROGRESS -> false
| EALREADY, EALREADY -> true
| EALREADY, _ | _, EALREADY -> false
| ENOTSOCK, ENOTSOCK -> true
| ENOTSOCK, _ | _, ENOTSOCK -> false
| EDESTADDRREQ, EDESTADDRREQ -> true
| EDESTADDRREQ, _ | _, EDESTADDRREQ -> false
| EMSGSIZE, EMSGSIZE -> true
| EMSGSIZE, _ | _, EMSGSIZE -> false
| EPROTOTYPE, EPROTOTYPE -> true
| EPROTOTYPE, _ | _, EPROTOTYPE -> false
| ENOPROTOOPT, ENOPROTOOPT -> true
| ENOPROTOOPT, _ | _, ENOPROTOOPT -> false
| EPROTONOSUPPORT, EPROTONOSUPPORT -> true
| EPROTONOSUPPORT, _ | _, EPROTONOSUPPORT -> false
| ESOCKTNOSUPPORT, ESOCKTNOSUPPORT -> true
| ESOCKTNOSUPPORT, _ | _, ESOCKTNOSUPPORT -> false
| EOPNOTSUPP, EOPNOTSUPP -> true
| EOPNOTSUPP, _ | _, EOPNOTSUPP -> false
| EPFNOSUPPORT, EPFNOSUPPORT -> true
| EPFNOSUPPORT, _ | _, EPFNOSUPPORT -> false
| EAFNOSUPPORT, EAFNOSUPPORT -> true
| EAFNOSUPPORT, _ | _, EAFNOSUPPORT -> false
| EADDRINUSE, EADDRINUSE -> true
| EADDRINUSE, _ | _, EADDRINUSE -> false
| EADDRNOTAVAIL, EADDRNOTAVAIL -> true
| EADDRNOTAVAIL, _ | _, EADDRNOTAVAIL -> false
| ENETDOWN, ENETDOWN -> true
| ENETDOWN, _ | _, ENETDOWN -> false
| ENETUNREACH, ENETUNREACH -> true
| ENETUNREACH, _ | _, ENETUNREACH -> false
| ENETRESET, ENETRESET -> true
| ENETRESET, _ | _, ENETRESET -> false
| ECONNABORTED, ECONNABORTED -> true
| ECONNABORTED, _ | _, ECONNABORTED -> false
| ECONNRESET, ECONNRESET -> true
| ECONNRESET, _ | _, ECONNRESET -> false
| ENOBUFS, ENOBUFS -> true
| ENOBUFS, _ | _, ENOBUFS -> false
| EISCONN, EISCONN -> true
| EISCONN, _ | _, EISCONN -> false
| ENOTCONN, ENOTCONN -> true
| ENOTCONN, _ | _, ENOTCONN -> false
| ESHUTDOWN, ESHUTDOWN -> true
| ESHUTDOWN, _ | _, ESHUTDOWN -> false
| ETOOMANYREFS, ETOOMANYREFS -> true
| ETOOMANYREFS, _ | _, ETOOMANYREFS -> false
| ETIMEDOUT, ETIMEDOUT -> true
| ETIMEDOUT, _ | _, ETIMEDOUT -> false
| ECONNREFUSED, ECONNREFUSED -> true
| ECONNREFUSED, _ | _, ECONNREFUSED -> false
| EHOSTDOWN, EHOSTDOWN -> true
| EHOSTDOWN, _ | _, EHOSTDOWN -> false
| EHOSTUNREACH, EHOSTUNREACH -> true
| EHOSTUNREACH, _ | _, EHOSTUNREACH -> false
| ELOOP, ELOOP -> true
| ELOOP, _ | _, ELOOP -> false
| EOVERFLOW, EOVERFLOW -> true
| EOVERFLOW, _ | _, EOVERFLOW -> false
| EUNKNOWNERR x, EUNKNOWNERR y -> Int.equal x y
;;
module Detailed = struct
type nonrec t = t * string * string
let raise (e, x, y) = raise (Unix.Unix_error (e, x, y))
let create error ~syscall ~arg = error, syscall, arg
let catch f x =
match f x with
| res -> Ok res
| exception Unix.Unix_error (error, syscall, arg) ->
Error (create error ~syscall ~arg)
;;
let equal (a1, b1, c1) (a2, b2, c2) =
equal a1 a2 && String.equal b1 b2 && String.equal c1 c2
;;
let to_string_hum (error, syscall, arg) =
Format.sprintf "%s(%s): %s" syscall arg (Unix.error_message error)
;;
end
end
module File_kind = struct
type t = Unix.file_kind =
| S_REG
| S_DIR
| S_CHR
| S_BLK
| S_LNK
| S_FIFO
| S_SOCK
let to_string = function
| S_REG -> "S_REG"
| S_DIR -> "S_DIR"
| S_CHR -> "S_CHR"
| S_BLK -> "S_BLK"
| S_LNK -> "S_LNK"
| S_FIFO -> "S_FIFO"
| S_SOCK -> "S_SOCK"
;;
let to_string_hum = function
| S_REG -> "regular file"
| S_DIR -> "directory"
| S_CHR -> "character device"
| S_BLK -> "block device"
| S_LNK -> "symbolic link"
| S_FIFO -> "named pipe"
| S_SOCK -> "socket"
;;
let equal x y =
match x, y with
| S_REG, S_REG -> true
| S_REG, _ | _, S_REG -> false
| S_DIR, S_DIR -> true
| S_DIR, _ | _, S_DIR -> false
| S_CHR, S_CHR -> true
| S_CHR, _ | _, S_CHR -> false
| S_BLK, S_BLK -> true
| S_BLK, _ | _, S_BLK -> false
| S_LNK, S_LNK -> true
| S_LNK, _ | _, S_LNK -> false
| S_FIFO, S_FIFO -> true
| S_FIFO, _ | _, S_FIFO -> false
| S_SOCK, S_SOCK -> true
;;
module Option = struct
[@@@warning "-37"]
(* The values are constructed on the C-side *)
type t =
| S_REG
| S_DIR
| S_CHR
| S_BLK
| S_LNK
| S_FIFO
| S_SOCK
| UNKNOWN
let elim ~none ~some t =
match t with
| S_REG -> some (S_REG : Unix.file_kind)
| S_DIR -> some S_DIR
| S_CHR -> some S_CHR
| S_BLK -> some S_BLK
| S_LNK -> some S_LNK
| S_FIFO -> some S_FIFO
| S_SOCK -> some S_SOCK
| UNKNOWN -> none ()
;;
end
end
module Readdir_result = struct
[@@@warning "-37"]
(* The values are constructed on the C-side *)
type t =
| End_of_directory
| Entry of string * File_kind.Option.t
end
external readdir_with_kind_if_available_unix
: Unix.dir_handle
-> Readdir_result.t
= "caml__dune_filesystem_stubs__readdir"
let readdir_with_kind_if_available_win32 : Unix.dir_handle -> Readdir_result.t =
fun dir ->
(* Windows also gives us the information about file kind and it's discarded by
[readdir]. We could do better here, but the Windows code is more
complicated. (there's an additional OCaml abstraction layer) *)
match Unix.readdir dir with
| exception End_of_file -> Readdir_result.End_of_directory
| entry -> Entry (entry, UNKNOWN)
;;
let readdir_with_kind_if_available : Unix.dir_handle -> Readdir_result.t =
if Stdlib.Sys.win32
then readdir_with_kind_if_available_win32
else readdir_with_kind_if_available_unix
;;
let read_directory_with_kinds_exn dir_path =
let dir = Unix.opendir dir_path in
Fun.protect
~finally:(fun () -> Unix.closedir dir)
(fun () ->
let rec loop acc =
match readdir_with_kind_if_available dir with
| Entry (("." | ".."), _) -> loop acc
| End_of_directory -> acc
| Entry (base, kind) ->
let k kind = loop ((base, kind) :: acc) in
let skip () = loop acc in
File_kind.Option.elim
kind
~none:(fun () ->
match Unix.lstat (Filename.concat dir_path base) with
| exception Unix.Unix_error _ ->
(* File disappeared between readdir & lstat system calls. Handle
as if readdir never told us about it *)
skip ()
| stat -> k stat.st_kind)
~some:k
in
loop [])
;;
let read_directory_with_kinds dir_path =
Unix_error.Detailed.catch read_directory_with_kinds_exn dir_path
;;
let read_directory_exn dir_path =
let dir = Unix.opendir dir_path in
Fun.protect
~finally:(fun () -> Unix.closedir dir)
(fun () ->
let rec loop acc =
match readdir_with_kind_if_available dir with
| Entry (("." | ".."), _) -> loop acc
| End_of_directory -> acc
| Entry (base, _) -> loop (base :: acc)
in
loop [])
;;
let read_directory dir_path = Unix_error.Detailed.catch read_directory_exn dir_path

49
unikernel/duniverse/dune_/otherlibs/stdune/src/dune_filesystem_stubs.mli Normal file
View file

@ -0,0 +1,49 @@
(** Efficient directory listing with kinds. *)
(** Auxiliary functions for working with Unix errors. *)
module Unix_error : sig
type t = Unix.error
val equal : t -> t -> bool
(** A Unix error along with the corresponding system call and argument, as
thrown in Unix exceptions. *)
module Detailed : sig
type nonrec t = t * string * string
val raise : t -> 'a
val create : Unix.error -> syscall:string -> arg:string -> t
(** Apply a function to an argument, catching a detailed Unix error. *)
val catch : ('a -> 'b) -> 'a -> ('b, t) result
val equal : t -> t -> bool
val to_string_hum : t -> string
end
end
(** Auxiliary functions for working with Unix file kinds. *)
module File_kind : sig
type t = Unix.file_kind =
| S_REG
| S_DIR
| S_CHR
| S_BLK
| S_LNK
| S_FIFO
| S_SOCK
val to_string : t -> string
val to_string_hum : t -> string
val equal : t -> t -> bool
end
(** [read_directory_with_kinds] is similar to [Sys.readdir], while additionally
returning kinds of the filesystem entries. *)
val read_directory_with_kinds
: string
-> ((string * File_kind.t) list, Unix_error.Detailed.t) Result.t
(** [read_directory_with_kinds d] returns all the filesystem entries in [d]
except for "." and "..", similar to [Sys.readdir]. *)
val read_directory : string -> (string list, Unix_error.Detailed.t) Result.t

83
unikernel/duniverse/dune_/otherlibs/stdune/src/dune_flock.c Normal file
View file

@ -0,0 +1,83 @@
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include <caml/threads.h>
#include <caml/unixsupport.h>
#ifdef _WIN32
#define FD_val(value) Handle_val(value)
CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) {
CAMLparam3(v_fd, v_block, v_exclusive);
OVERLAPPED overlapped = { 0 };
DWORD ok, dwFlags = 0;
if (Bool_val(v_exclusive)) {
dwFlags |= LOCKFILE_EXCLUSIVE_LOCK;
}
if (!Bool_val(v_block)) {
dwFlags |= LOCKFILE_FAIL_IMMEDIATELY;
}
caml_release_runtime_system();
ok = LockFileEx(FD_val(v_fd), dwFlags, 0, MAXDWORD, MAXDWORD, &overlapped);
caml_acquire_runtime_system();
if (!ok) {
win32_maperr(GetLastError());
uerror("LockFileEx", Nothing);
}
CAMLreturn(Val_unit);
}
CAMLprim value dune_flock_unlock(value v_fd) {
CAMLparam1(v_fd);
OVERLAPPED overlapped = { 0 };
DWORD ok;
caml_release_runtime_system();
ok = UnlockFileEx(FD_val(v_fd), 0, MAXDWORD, MAXDWORD, &overlapped);
caml_acquire_runtime_system();
if (!ok) {
win32_maperr(GetLastError());
uerror("UnlockFileEx", Nothing);
}
CAMLreturn(Val_unit);
}
#else /* _WIN32 */
#include <sys/file.h>
#define FD_val(value) Int_val(value)
CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) {
CAMLparam3(v_fd, v_block, v_exclusive);
int flags = 0;
if (Bool_val(v_exclusive)) {
flags |= LOCK_EX;
} else {
flags |= LOCK_SH;
}
if (!Bool_val(v_block)) {
flags |= LOCK_NB;
}
caml_release_runtime_system();
int ret = flock(FD_val(v_fd), flags);
caml_acquire_runtime_system();
if (ret == 0) {
CAMLreturn(Val_unit);
} else {
uerror("flock", Nothing);
}
}
CAMLprim value dune_flock_unlock(value v_fd) {
CAMLparam1(v_fd);
caml_release_runtime_system();
int ret = flock(FD_val(v_fd), LOCK_UN);
caml_acquire_runtime_system();
if (ret == 0) {
CAMLreturn(Val_unit);
} else {
uerror("flock", Nothing);
}
}
#endif /* _WIN32 */

25
unikernel/duniverse/dune_/otherlibs/stdune/src/either.ml Normal file
View file

@ -0,0 +1,25 @@
include struct
[@@@warning "-33"]
(* This open is unused with OCaml >= 4.12 since the stdlib defines an either type *)
open Dune_either
open Stdlib
type ('a, 'b) t = ('a, 'b) Either.t =
| Left of 'a
| Right of 'b
end
let map t ~l ~r =
match t with
| Left x -> l x
| Right x -> r x
;;
let left x = Left x
let right x = Right x
let to_dyn f g = function
| Left a -> f a
| Right b -> g b
;;

18
unikernel/duniverse/dune_/otherlibs/stdune/src/either.mli Normal file
View file

@ -0,0 +1,18 @@
(** Left or right *)
include sig
[@@@warning "-33"]
(* This open is unused with OCaml >= 4.12 since the stdlib defines an either type *)
open Dune_either
open Stdlib
type ('a, 'b) t = ('a, 'b) Either.t =
| Left of 'a
| Right of 'b
end
val map : ('a, 'b) t -> l:('a -> 'c) -> r:('b -> 'c) -> 'c
val left : 'a -> ('a, _) t
val right : 'b -> (_, 'b) t
val to_dyn : ('a -> Dyn.t) -> ('b -> Dyn.t) -> ('a, 'b) t -> Dyn.t

93
unikernel/duniverse/dune_/otherlibs/stdune/src/env.ml Normal file
View file

@ -0,0 +1,93 @@
module Sys = Stdlib.Sys
module Var = struct
module T = struct
type t = string
let compare =
if Sys.win32
then fun a b -> String.compare (String.lowercase a) (String.lowercase b)
else String.compare
;;
let to_dyn = Dyn.string
end
let temp_dir = if Sys.win32 then "TEMP" else "TMPDIR"
include Comparable.Make (T)
include T
end
module Set = Var.Set
module Map = Var.Map
(* The use of [mutable] here is safe, since we never call (back) to the
memoization framework when computing [unix]. *)
type t =
{ vars : string Map.t
; mutable unix : string list option
}
let equal t { vars; unix = _ } = Map.equal ~equal:String.equal t.vars vars
let hash { vars; unix = _ } = Poly.hash vars
let of_map vars = { vars; unix = None }
let empty = of_map Map.empty
let vars t = Var.Set.of_keys t.vars
let get t k = Map.find t.vars k
let to_unix t =
match t.unix with
| Some v -> v
| None ->
let res =
Map.foldi ~init:[] ~f:(fun k v acc -> Printf.sprintf "%s=%s" k v :: acc) t.vars
in
t.unix <- Some res;
res
;;
let of_unix arr =
Array.to_list arr
|> List.map ~f:(fun s ->
match String.lsplit2 s ~on:'=' with
| None ->
Code_error.raise
"Env.of_unix: entry without '=' found in the environment"
[ "var", String s ]
| Some (k, v) -> k, v)
|> Map.of_list_multi
|> Map.map ~f:(function
| [] -> assert false
| x :: _ -> x)
;;
let initial = of_map (of_unix (Unix.environment ()))
let of_unix u = of_map (of_unix u)
let add t ~var ~value = of_map (Map.set t.vars var value)
let mem t ~var = Map.mem t.vars var
let remove t ~var = of_map (Map.remove t.vars var)
let extend t ~vars = if Map.is_empty vars then t else of_map (Map.superpose vars t.vars)
let extend_env x y = if Map.is_empty x.vars then y else extend x ~vars:y.vars
let to_dyn t =
let open Dyn in
Map.to_dyn string t.vars
;;
let diff x y =
Map.merge x.vars y.vars ~f:(fun _k vx vy ->
match vy with
| Some _ -> None
| None -> vx)
|> of_map
;;
let update t ~var ~f = of_map (Map.update t.vars var ~f)
let of_string_map m =
of_map (String.Map.foldi ~init:Map.empty ~f:(fun k v acc -> Map.set acc k v) m)
;;
let iter t = Map.iteri t.vars
let to_map t = t.vars

49
unikernel/duniverse/dune_/otherlibs/stdune/src/env.mli Normal file
View file

@ -0,0 +1,49 @@
(* Note that operations relating to the PATH environment variable are defined
in a separate module [Env_path]. *)
module Var : sig
type t = string
val compare : t -> t -> Ordering.t
val temp_dir : t
include Comparable_intf.S with type key := t
val to_dyn : t -> Dyn.t
end
type t
val hash : t -> int
include Comparable_intf.S with type key := Var.t
val equal : t -> t -> bool
val empty : t
val vars : t -> Var.Set.t
(** The environment when the process started *)
val initial : t
val to_unix : t -> string list
val of_unix : string array -> t
val get : t -> Var.t -> string option
(** [extend env ~vars] adds all variables from [vars] to [env] overwriting any
existing values of those variables in [env] *)
val extend : t -> vars:string Map.t -> t
(** [extend_env a b] adds all variables from [b] to [a] overwriting any
existing values of those variables in [a]. *)
val extend_env : t -> t -> t
val add : t -> var:Var.t -> value:string -> t
val mem : t -> var:Var.t -> bool
val remove : t -> var:Var.t -> t
val diff : t -> t -> t
val update : t -> var:Var.t -> f:(string option -> string option) -> t
val to_dyn : t -> Dyn.t
val of_string_map : string String.Map.t -> t
val to_map : t -> string Map.t
val of_map : string Map.t -> t
val iter : t -> f:(string -> string -> unit) -> unit

41
unikernel/duniverse/dune_/otherlibs/stdune/src/env_path.ml Normal file
View file

@ -0,0 +1,41 @@
let var = "PATH"
let cons ?(var = var) env ~dir =
Env.update env ~var ~f:(fun _PATH -> Some (Bin.cons_path dir ~_PATH))
;;
(* [cons_multi env ~dirs] adds each path in [dirs] to the start of the PATH
variable in [env], preserving their order *)
let cons_multi env ~dirs =
Env.update env ~var ~f:(fun init ->
List.fold_right dirs ~init ~f:(fun dir acc -> Some (Bin.cons_path dir ~_PATH:acc)))
;;
let path env =
match Env.get env var with
| None -> []
| Some s -> Bin.parse_path s
;;
let extend_env_concat_path a b =
let a_including_b's_path = cons_multi a ~dirs:(path b) in
let b_without_path = Env.remove b ~var in
Env.extend_env a_including_b's_path b_without_path
;;
let system_shell_exn =
let cmd, arg, os = if Sys.win32 then "cmd", "/c", " on Windows" else "sh", "-c", "" in
let bin = lazy (Bin.which ~path:(path Env.initial) cmd) in
fun ~needed_to ->
match Lazy.force bin with
| Some path -> path, arg
| None ->
User_error.raise
[ Pp.textf
"I need %s to %s but I couldn't find it :(\nWho doesn't have %s%s?!"
cmd
needed_to
cmd
os
]
;;

18
unikernel/duniverse/dune_/otherlibs/stdune/src/env_path.mli Normal file
View file

@ -0,0 +1,18 @@
(** Handle the [PATH] environment variable. *)
(* this isn't in [Env] to avoid cycles *)
val var : Env.Var.t
(** [cons env ~dir] adds [dir] to the start of the PATH variable in [env] *)
val cons : ?var:Env.Var.t -> Env.t -> dir:Path.t -> Env.t
val path : Env.t -> Path.t list
(** [extend_env_concat_path a b] adds all variables from [b] to [a]
overwriting any existing values of those variables in [a] except for PATH
which is set to the concatenation of the PATH variables from [a] and [b]
with the PATH entries from [b] preceding the PATH entries from [a] *)
val extend_env_concat_path : Env.t -> Env.t -> Env.t
val system_shell_exn : needed_to:string -> Path.t * string

86
unikernel/duniverse/dune_/otherlibs/stdune/src/escape.ml Normal file
View file

@ -0,0 +1,86 @@
module String = StringLabels
type quote =
| Needs_quoting_with_length of int
| No_quoting
let quote_length s =
let n = ref 0 in
let len = String.length s in
let needs_quoting = ref false in
for i = 0 to len - 1 do
n
:= !n
+
match String.unsafe_get s i with
| '\"' | '\\' | '\n' | '\t' | '\r' | '\b' ->
needs_quoting := true;
2
| ' ' ->
needs_quoting := true;
1
| '!' .. '~' -> 1
| _ ->
needs_quoting := true;
4
done;
if !needs_quoting
then Needs_quoting_with_length len
else (
assert (len = !n);
No_quoting)
;;
let escape_to s ~dst:s' ~ofs =
let n = ref ofs in
let len = String.length s in
for i = 0 to len - 1 do
(match String.unsafe_get s i with
| ('\"' | '\\') as c ->
Bytes.unsafe_set s' !n '\\';
incr n;
Bytes.unsafe_set s' !n c
| '\n' ->
Bytes.unsafe_set s' !n '\\';
incr n;
Bytes.unsafe_set s' !n 'n'
| '\t' ->
Bytes.unsafe_set s' !n '\\';
incr n;
Bytes.unsafe_set s' !n 't'
| '\r' ->
Bytes.unsafe_set s' !n '\\';
incr n;
Bytes.unsafe_set s' !n 'r'
| '\b' ->
Bytes.unsafe_set s' !n '\\';
incr n;
Bytes.unsafe_set s' !n 'b'
| ' ' .. '~' as c -> Bytes.unsafe_set s' !n c
| c ->
let a = Char.code c in
Bytes.unsafe_set s' !n '\\';
incr n;
Bytes.unsafe_set s' !n (Char.unsafe_chr (48 + (a / 100)));
incr n;
Bytes.unsafe_set s' !n (Char.unsafe_chr (48 + (a / 10 mod 10)));
incr n;
Bytes.unsafe_set s' !n (Char.unsafe_chr (48 + (a mod 10))));
incr n
done
;;
(* Surround [s] with quotes, escaping it if necessary. *)
let quote_if_needed s =
let len = String.length s in
match quote_length s with
| No_quoting -> if s = "" then "\"\"" else s
| Needs_quoting_with_length n ->
let s' = Bytes.create (n + 2) in
Bytes.unsafe_set s' 0 '"';
if len = 0 || n > len
then escape_to s ~dst:s' ~ofs:1
else Bytes.blit_string ~src:s ~src_pos:0 ~dst:s' ~dst_pos:1 ~len;
Bytes.unsafe_set s' (n + 1) '"';
Bytes.unsafe_to_string s'
;;

1
unikernel/duniverse/dune_/otherlibs/stdune/src/escape.mli Normal file
View file

@ -0,0 +1 @@
val quote_if_needed : string -> string

17
unikernel/duniverse/dune_/otherlibs/stdune/src/execution_env.ml Normal file
View file

@ -0,0 +1,17 @@
let inside_emacs = Option.is_some (Env.get Env.initial "INSIDE_EMACS")
let inside_ci = Option.is_some (Env.get Env.initial "CI")
module Inside_dune = struct
type t =
| Yes
| In_context of Path.Build.t
let var = "INSIDE_DUNE"
let value = function
| Yes -> "1"
| In_context b -> Path.to_absolute_filename (Path.build b)
;;
end
let inside_dune = Option.is_some (Env.get Env.initial Inside_dune.var)

19
unikernel/duniverse/dune_/otherlibs/stdune/src/execution_env.mli Normal file
View file

@ -0,0 +1,19 @@
(** Are we running inside an emacs shell? *)
val inside_emacs : bool
(** Are we running inside Dune? *)
val inside_dune : bool
(** Are we running in CI?. This checks the CI environment variable which is
supported by travis, gitlab.*)
val inside_ci : bool
module Inside_dune : sig
type t =
| Yes
| In_context of Path.Build.t
val var : Env.Var.t
val value : t -> string
end

41
unikernel/duniverse/dune_/otherlibs/stdune/src/exn.ml Normal file
View file

@ -0,0 +1,41 @@
module String = Stdlib.StringLabels
type t = exn
external raise : exn -> _ = "%raise"
external raise_notrace : exn -> _ = "%raise_notrace"
external reraise : exn -> _ = "%reraise"
let protectx x ~f ~finally =
match f x with
| y ->
finally x;
y
| exception e ->
finally x;
raise e
;;
let protect ~f ~finally = protectx () ~f ~finally
let pp_uncaught ~backtrace fmt exn =
let s =
Printf.sprintf "%s\n%s" (Printexc.to_string exn) backtrace
|> String_split.split_lines
|> List.map ~f:(Printf.sprintf "| %s")
|> String.concat ~sep:"\n"
in
let line = String.make 71 '-' in
Format.fprintf
fmt
"/%s\n| @{<error>Internal error@}: Uncaught exception.\n%s\n\\%s@."
line
s
line
;;
let pp exn = Pp.text (Printexc.to_string exn)
let raise_with_backtrace = Printexc.raise_with_backtrace
let equal = ( = )
let hash = Stdlib.Hashtbl.hash
let to_dyn exn = Dyn.String (Printexc.to_string exn)

15
unikernel/duniverse/dune_/otherlibs/stdune/src/exn.mli Normal file
View file

@ -0,0 +1,15 @@
(** Exceptions *)
type t = exn
external raise : exn -> _ = "%raise"
external raise_notrace : exn -> _ = "%raise_notrace"
external reraise : exn -> _ = "%reraise"
val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a
val protectx : 'a -> f:('a -> 'b) -> finally:('a -> unit) -> 'b
val pp_uncaught : backtrace:string -> Format.formatter -> t -> unit
val pp : t -> _ Pp.t
val raise_with_backtrace : exn -> Printexc.raw_backtrace -> _
val equal : t -> t -> bool
val hash : t -> int
val to_dyn : t -> Dyn.t

44
unikernel/duniverse/dune_/otherlibs/stdune/src/exn_with_backtrace.ml Normal file
View file

@ -0,0 +1,44 @@
type t =
{ exn : exn
; backtrace : Printexc.raw_backtrace
}
let capture exn = { exn; backtrace = Printexc.get_raw_backtrace () }
let try_with f =
match f () with
| r -> Result.Ok r
| exception exn -> Error (capture exn)
;;
let try_with_never_returns f =
match f () with
| (_ : Nothing.t) -> .
| exception exn -> capture exn
;;
let reraise { exn; backtrace } = Exn.raise_with_backtrace exn backtrace
let pp_uncaught fmt { exn; backtrace } =
Exn.pp_uncaught ~backtrace:(Printexc.raw_backtrace_to_string backtrace) fmt exn
;;
let pp { exn; backtrace } =
let open Pp.O in
Exn.pp exn
++ Pp.newline
++ Pp.text "backtrace:"
++ Pp.newline
++ Pp.text (Printexc.raw_backtrace_to_string backtrace)
;;
let map { exn; backtrace } ~f = { exn = f exn; backtrace }
let map_and_reraise t ~f = reraise (map ~f t)
let to_dyn { exn; backtrace } =
let open Dyn in
record
[ "exn", string (Printexc.to_string exn)
; "backtrace", string (Printexc.raw_backtrace_to_string backtrace)
]
;;

21
unikernel/duniverse/dune_/otherlibs/stdune/src/exn_with_backtrace.mli Normal file
View file

@ -0,0 +1,21 @@
(** An exception together with the backtrace that raised it. *)
type t =
{ exn : exn
; backtrace : Printexc.raw_backtrace
}
val try_with : (unit -> 'a) -> ('a, t) Result.t
val try_with_never_returns : (unit -> Nothing.t) -> t
(** This function should be the very first thing called in the exception handler
if you want it to work correctly. Otherwise it might capture an incorrect
backtrace. *)
val capture : exn -> t
val reraise : t -> 'a
val pp_uncaught : Format.formatter -> t -> unit
val pp : t -> _ Pp.t
val map : t -> f:(exn -> exn) -> t
val map_and_reraise : t -> f:(exn -> exn) -> 'a
val to_dyn : t -> Dyn.t

31
unikernel/duniverse/dune_/otherlibs/stdune/src/fdecl.ml Normal file
View file

@ -0,0 +1,31 @@
type 'a state =
| Unset
| Set of 'a
type 'a t =
{ mutable state : 'a state
; to_dyn : 'a -> Dyn.t
}
let create to_dyn = { state = Unset; to_dyn }
let set t new_ =
match t.state with
| Unset -> t.state <- Set new_
| Set old ->
Code_error.raise
"Fdecl.set: already set"
[ "old", t.to_dyn old; "new_", t.to_dyn new_ ]
;;
let get t =
match t.state with
| Unset -> Code_error.raise "Fdecl.get: not set" []
| Set x -> x
;;
let to_dyn t =
match t.state with
| Unset -> Dyn.variant "Unset" []
| Set a -> Dyn.variant "Set" [ t.to_dyn a ]
;;

17
unikernel/duniverse/dune_/otherlibs/stdune/src/fdecl.mli Normal file
View file

@ -0,0 +1,17 @@
(** Forward declarations *)
type 'a t
(** [create to_dyn] creates a forward declaration. The [to_dyn] parameter is
used for reporting errors in [set], [set_idempotent] and [get]. *)
val create : ('a -> Dyn.t) -> 'a t
(** [set t x] sets the value that will be returned by [get t] to [x]. Raises if
[set] was already called. *)
val set : 'a t -> 'a -> unit
(** [get t] returns the [x] if [set comp x] was called. Raises if [set] has not
been called yet. *)
val get : 'a t -> 'a
val to_dyn : 'a t -> Dyn.t

41
unikernel/duniverse/dune_/otherlibs/stdune/src/filename.ml Normal file
View file

@ -0,0 +1,41 @@
include Stdlib.Filename
type t = string
module Extension = struct
type nonrec t = t
module Set = String.Set
module Map = String.Map
end
let split_extension fn =
let ext = extension fn in
String.sub fn ~pos:0 ~len:(String.length fn - String.length ext), ext
;;
let split_extension_after_dot fn =
match extension fn with
| "" -> fn, ""
| s -> String.split_n fn (String.length fn - String.length s + 1)
;;
type program_name_kind =
| In_path
| Relative_to_current_dir
| Absolute
let analyze_program_name fn =
if not (is_relative fn)
then Absolute
else if String.contains fn '/' || (Stdlib.Sys.win32 && String.contains fn '\\')
then Relative_to_current_dir
else In_path
;;
let compare = String.compare
let equal = String.equal
let chop_extension = `Use_remove_extension
module Set = String.Set
module Map = String.Map

33
unikernel/duniverse/dune_/otherlibs/stdune/src/filename.mli Normal file
View file

@ -0,0 +1,33 @@
(** Represent a path component.
A path component is just a string without a '/' character. *)
include module type of struct
include Stdlib.Filename
end
(* TODO add invariants and make this abstract or private *)
type t = string
module Extension : sig
type nonrec t = t
module Set = String.Set
module Map = String.Map
end
val split_extension : t -> string * Extension.t
val split_extension_after_dot : t -> string * string
type program_name_kind =
| In_path
| Relative_to_current_dir
| Absolute
val analyze_program_name : t -> program_name_kind
val equal : t -> t -> bool
val compare : t -> t -> Ordering.t
val chop_extension : [ `Use_remove_extension ]
module Set = String.Set
module Map = String.Map

28
unikernel/duniverse/dune_/otherlibs/stdune/src/filename_set.ml Normal file
View file

@ -0,0 +1,28 @@
(* CR-someday amokhov: Switch from sets to "flat sets" backed by immutable arrays. *)
type t =
{ dir : Path.t
; filenames : Filename.Set.t
}
let equal t { dir; filenames } =
Path.equal t.dir dir && Filename.Set.equal filenames t.filenames
;;
let dir { dir; filenames = _ } = dir
let filenames { dir = _; filenames } = filenames
let empty ~dir = { dir; filenames = String.Set.empty }
let is_empty { dir = _; filenames } = Filename.Set.is_empty filenames
let create ?filter ~dir filenames =
match filter with
| None -> { dir; filenames }
| Some f ->
{ dir
; filenames =
Filename.Set.to_list filenames
|> List.filter ~f:(fun basename -> f ~basename)
|> Filename.Set.of_list
}
;;
let to_list { dir; filenames } = Filename.Set.to_list_map filenames ~f:(Path.relative dir)

20
unikernel/duniverse/dune_/otherlibs/stdune/src/filename_set.mli Normal file
View file

@ -0,0 +1,20 @@
(** Like [Path.Set.t] but tailored for representing sets of file names in the same parent
directory. Compared to [Path.Set.t], [Filename_set.t] statically enforces an important
invariant, and can also be processed more efficiently. *)
type t
val equal : t -> t -> bool
(** The directory of the filename set. *)
val dir : t -> Path.t
(** The set of file names, all relative to [dir]. *)
val filenames : t -> Filename.Set.t
val empty : dir:Path.t -> t
val is_empty : t -> bool
(* CR-soon amokhov: Decouple [create] from [filter]. *)
val create : ?filter:(basename:string -> bool) -> dir:Path.t -> Filename.Set.t -> t
val to_list : t -> Path.t list

10
unikernel/duniverse/dune_/otherlibs/stdune/src/flags/dune Normal file
View file

@ -0,0 +1,10 @@
(executable
(name gen_flags))
(rule
(deps
(:script gen_flags.ml))
(action
(with-stdout-to
sexp
(run ./gen_flags.exe %{system}))))

1
unikernel/duniverse/dune_/otherlibs/stdune/src/flags/gen_flags.ml Normal file
View file

@ -0,0 +1 @@
let () = Printf.printf @@ if Sys.argv.(1) = "beos" then {|(-cclib -lbsd)|} else "()"

15
unikernel/duniverse/dune_/otherlibs/stdune/src/float.ml Normal file
View file

@ -0,0 +1,15 @@
type t = float
let of_string f =
try Some (float_of_string f) with
| _ -> None
;;
let to_string = string_of_float
let compare x y = Ordering.of_int (compare x y)
let max x y =
match compare x y with
| Eq | Gt -> x
| Lt -> y
;;

6
unikernel/duniverse/dune_/otherlibs/stdune/src/float.mli Normal file
View file

@ -0,0 +1,6 @@
type t = float
val of_string : string -> t option
val to_string : t -> string
val compare : t -> t -> Ordering.t
val max : t -> t -> t

37
unikernel/duniverse/dune_/otherlibs/stdune/src/flock.ml Normal file
View file

@ -0,0 +1,37 @@
type t = Unix.file_descr
let create x = x
external gen_lock : t -> block:bool -> exclusive:bool -> unit = "dune_flock_lock"
type lock =
| Shared
| Exclusive
let is_exclusive = function
| Exclusive -> true
| Shared -> false
;;
let lock_block t lock =
match gen_lock t ~block:true ~exclusive:(is_exclusive lock) with
| () -> Ok ()
| exception Unix.Unix_error (err, _, _) -> Error err
;;
let lock_non_block t lock =
match gen_lock t ~block:false ~exclusive:(is_exclusive lock) with
| () -> Ok `Success
| exception Unix.Unix_error ((EWOULDBLOCK | EAGAIN | EACCES), _, _) -> Ok `Failure
| exception Unix.Unix_error (err, _, _) -> Error err
;;
external unlock : t -> unit = "dune_flock_unlock"
let unlock t =
match unlock t with
| () -> Ok ()
| exception Unix.Unix_error (err, _, _) -> Error err
;;
let fd x = x

15
unikernel/duniverse/dune_/otherlibs/stdune/src/flock.mli Normal file
View file

@ -0,0 +1,15 @@
(** Wrapper around [flock]. Implements dune's global locking. Mostly exposed for
testing *)
type t
val fd : t -> Unix.file_descr
val create : Unix.file_descr -> t
type lock =
| Shared
| Exclusive
val lock_block : t -> lock -> (unit, Unix.error) result
val lock_non_block : t -> lock -> ([ `Success | `Failure ], Unix.error) result
val unlock : t -> (unit, Unix.error) result

4
unikernel/duniverse/dune_/otherlibs/stdune/src/format.ml Normal file
View file

@ -0,0 +1,4 @@
(* added in OCaml 5.2 *)
let[@warning "-32"] pp_infinity = Int.max_int
include Stdlib.Format

3
unikernel/duniverse/dune_/otherlibs/stdune/src/format.mli Normal file
View file

@ -0,0 +1,3 @@
val pp_infinity : int [@@warning "-32"]
include module type of Stdlib.Format

239
unikernel/duniverse/dune_/otherlibs/stdune/src/fpath.ml Normal file
View file

@ -0,0 +1,239 @@
let is_root =
if Sys.unix
then fun x -> x = "/" || x = "."
else
(* CR-someday rgrinberg: can we do better on windows? *)
fun s -> Filename.dirname s = s
;;
let initial_cwd = Stdlib.Sys.getcwd ()
type mkdir_result =
| Already_exists
| Created
| Missing_parent_directory
let mkdir ?(perms = 0o777) t_s =
try
Unix.mkdir t_s perms;
Created
with
| Unix.Unix_error (EEXIST, _, _) -> Already_exists
| Unix.Unix_error (ENOENT, _, _) -> Missing_parent_directory
;;
type mkdir_p_result =
| Already_exists
| Created
let rec mkdir_p ?perms t_s =
match mkdir ?perms t_s with
| Created -> Created
| Already_exists -> Already_exists
| Missing_parent_directory ->
if is_root t_s
then
Code_error.raise
"Impossible happened: [Fpath.mkdir] refused to create a directory at the root, \
allegedly because its parent was missing"
[]
else (
let parent = Filename.dirname t_s in
match mkdir_p ?perms parent with
| Created | Already_exists ->
(* The [Already_exists] case might happen if some other process managed
to create the parent directory concurrently. *)
(match mkdir t_s ?perms with
| Created -> Created
| Already_exists -> Already_exists
| Missing_parent_directory ->
(* But we just successfully created the parent directory. So it was
likely deleted right now. Let's give up *)
Code_error.raise "failed to create parent directory" [ "t_s", Dyn.string t_s ]))
;;
let resolve_link path =
match Unix.readlink path with
| exception Unix.Unix_error (EINVAL, _, _) -> Ok None
| exception Unix.Unix_error (error, syscall, arg) ->
Error (Dune_filesystem_stubs.Unix_error.Detailed.create ~syscall ~arg error)
| link ->
Ok
(Some
(if Filename.is_relative link
then Filename.concat (Filename.dirname path) link
else link))
;;
type follow_symlink_error =
| Not_a_symlink
| Max_depth_exceeded
| Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t
let follow_symlink path =
let rec loop n path =
if n = 0
then Error Max_depth_exceeded
else (
match resolve_link path with
| Error e -> Error (Unix_error e)
| Ok None -> Ok path
| Ok (Some path) -> loop (n - 1) path)
in
match resolve_link path with
| Ok None -> Error Not_a_symlink
| Ok (Some p) -> loop 20 p
| Error e -> Error (Unix_error e)
;;
let rec follow_symlinks path =
let parent = Filename.dirname path in
let file = Filename.basename path in
(* If we reached the root, just return the path. *)
if parent = path
then Some path
else if parent = Filename.current_dir_name
then
(* Only keep the initial ["."] if it was in the path. *)
if path = Filename.concat Filename.current_dir_name file then Some path else Some file
else (
(* Recurse on parent, and re-add toplevel file. *)
match follow_symlinks parent with
| None -> None
| Some parent ->
let path = Filename.concat parent file in
(* Normalize the result. *)
(match follow_symlink path with
| Ok p -> Some p
| Error Max_depth_exceeded -> None
| Error _ -> Some path))
;;
let win32_unlink fn =
try Unix.unlink fn with
| Unix.Unix_error (Unix.EACCES, _, _) as e ->
(try
(* Try removing the read-only attribute *)
Unix.chmod fn 0o666;
Unix.unlink fn
with
| Unix.Unix_error (Unix.EACCES, _, _) ->
(* On Windows a virus scanner frequently has a lock on new executables for a short while - just retry *)
let rec retry_loop cnt =
Unix.sleep 1;
try Unix.unlink fn with
| Unix.Unix_error (Unix.EACCES, _, _) ->
if cnt > 0 then retry_loop (cnt - 1) else raise e
in
retry_loop 30)
;;
let unlink_exn = if Stdlib.Sys.win32 then win32_unlink else Unix.unlink
type unlink_status =
| Success
| Does_not_exist
| Is_a_directory
| Error of exn
let unlink t =
match unlink_exn t with
| () -> Success
| exception exn ->
(match exn with
| Unix.Unix_error (ENOENT, _, _) -> Does_not_exist
| Unix.Unix_error (error, _, _) ->
(match error, Platform.OS.value with
| EISDIR, _ | EPERM, Darwin -> Is_a_directory
| _ -> Error exn)
| _ -> Error exn)
;;
let unlink_no_err t =
try unlink_exn t with
| _ -> ()
;;
type clear_dir_result =
| Cleared
| Directory_does_not_exist
let rec clear_dir dir =
match Dune_filesystem_stubs.read_directory_with_kinds dir with
| Error (ENOENT, _, _) -> Directory_does_not_exist
| Error (error, _, _) ->
raise (Unix.Unix_error (error, dir, "Stdune.Path.rm_rf: read_directory_with_kinds"))
| Ok listing ->
List.iter listing ~f:(fun (fn, kind) ->
let fn = Filename.concat dir fn in
(* Note that by the time we reach this point, [fn] might have been
deleted by a concurrent process. Both [rm_rf_dir] and [unlink_no_err]
will tolerate such phantom paths and succeed. *)
match kind with
| Unix.S_DIR -> rm_rf_dir fn
| _ -> unlink_no_err fn);
Cleared
and rm_rf_dir path =
match clear_dir path with
| Directory_does_not_exist -> ()
| Cleared ->
(match Unix.rmdir path with
| () -> ()
| exception Unix.Unix_error (ENOENT, _, _) ->
(* How can we end up here? [clear_dir] cleared the directory successfully,
but by the time the above [Unix.rmdir] was called, another process
deleted the directory. *)
())
;;
let rm_rf fn =
match Unix.lstat fn with
| exception Unix.Unix_error (ENOENT, _, _) -> ()
| { Unix.st_kind = S_DIR; _ } -> rm_rf_dir fn
| _ -> unlink_exn fn
;;
let traverse ~dir ~init ~on_file ~on_dir ~on_broken_symlink =
let rec loop root stack acc =
match stack with
| [] -> acc
| dir :: dirs ->
let dir_path = Filename.concat root dir in
(match Dune_filesystem_stubs.read_directory_with_kinds dir_path with
| Error e -> Dune_filesystem_stubs.Unix_error.Detailed.raise e
| Ok entries ->
let stack, acc =
List.fold_left entries ~init:(dirs, acc) ~f:(fun (stack, acc) (fname, kind) ->
match (kind : Unix.file_kind) with
| S_DIR -> Filename.concat dir fname :: stack, on_dir ~dir fname acc
| S_REG -> stack, on_file ~dir fname acc
| S_LNK ->
let path = Filename.concat dir_path fname in
(match (Unix.stat path).st_kind with
| exception Unix.Unix_error (Unix.ENOENT, _, _) ->
stack, on_broken_symlink ~dir fname acc
| S_DIR -> Filename.concat dir fname :: stack, on_dir ~dir fname acc
| S_REG -> stack, on_file ~dir fname acc
| _ -> stack, acc)
| _ -> stack, acc)
in
loop root stack acc)
in
loop dir [ "" ] init
;;
let traverse_files ~dir ~init ~f =
let skip = fun ~dir:_ _fname acc -> acc in
traverse ~dir ~init ~on_dir:skip ~on_broken_symlink:skip ~on_file:f
;;
let is_broken_symlink path =
let stats = Unix.lstat path in
match (stats.st_kind : Unix.file_kind) with
| S_LNK ->
(match Unix.stat path with
| exception Unix.Unix_error (Unix.ENOENT, _, _) -> true
| _ -> false)
| _ -> false
;;

72
unikernel/duniverse/dune_/otherlibs/stdune/src/fpath.mli Normal file
View file

@ -0,0 +1,72 @@
(** Functions on paths that are represented as strings *)
type mkdir_result =
| Already_exists (** The directory already exists. No action was taken. *)
| Created (** The directory was created. *)
| Missing_parent_directory
(** No parent directory, use [mkdir_p] if you want to create it too. *)
val mkdir : ?perms:int -> string -> mkdir_result
type mkdir_p_result =
| Already_exists (** The directory already exists. No action was taken. *)
| Created (** The directory was created. *)
val mkdir_p : ?perms:int -> string -> mkdir_p_result
type follow_symlink_error =
| Not_a_symlink
| Max_depth_exceeded
| Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t
val follow_symlink : string -> (string, follow_symlink_error) result
(** [follow_symlinks path] returns a file path that is equivalent to [path], but
free of symbolic links. The value [None] is returned if the maximum symbolic
link depth is reached (i.e., [follow_symlink] returns the value
[Error Max_depth_exceeded] on some intermediate path). *)
val follow_symlinks : string -> string option
val unlink_exn : string -> unit
val unlink_no_err : string -> unit
type unlink_status =
| Success
| Does_not_exist
| Is_a_directory
| Error of exn
(** Unlink and return error, if any. *)
val unlink : string -> unlink_status
val initial_cwd : string
type clear_dir_result =
| Cleared
| Directory_does_not_exist
val clear_dir : string -> clear_dir_result
(** If the path does not exist, this function is a no-op. *)
val rm_rf : string -> unit
val is_root : string -> bool
val traverse
: dir:string
-> init:'acc
-> on_file:(dir:string -> Filename.t -> 'acc -> 'acc)
-> on_dir:(dir:string -> Filename.t -> 'acc -> 'acc)
-> on_broken_symlink:(dir:string -> Filename.t -> 'acc -> 'acc)
-> 'acc
val traverse_files
: dir:string
-> init:'acc
-> f:(dir:string -> Filename.t -> 'acc -> 'acc)
-> 'acc
(** [is_broken_simlink path] returns [true] iff [path] refers to a symlink
whose target does not exist. Returns false if [path] is not a symlink, or
is a symlink whose target exists. *)
val is_broken_symlink : string -> bool

6
unikernel/duniverse/dune_/otherlibs/stdune/src/hashable.ml Normal file
View file

@ -0,0 +1,6 @@
module type S = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end

88
unikernel/duniverse/dune_/otherlibs/stdune/src/hashtbl.ml Normal file
View file

@ -0,0 +1,88 @@
module type S = Hashtbl_intf.S
module Make (H : sig
include Hashable.S
val to_dyn : t -> Dyn.t
end) =
struct
include MoreLabels.Hashtbl.Make (H)
let[@ocaml.warning "-32"] add = `Use_set
let find = find_opt
let find_exn t key =
match find_opt t key with
| Some v -> v
| None -> Code_error.raise "Hashtbl.find_exn" [ "key", H.to_dyn key ]
;;
let set t key data = replace t ~key ~data
let find_or_add t key ~f =
match find t key with
| Some x -> x
| None ->
let x = f key in
set t key x;
x
;;
let foldi t ~init ~f = fold t ~init ~f:(fun ~key ~data acc -> f key data acc)
let fold t ~init ~f = foldi t ~init ~f:(fun _ x -> f x)
let of_list l =
let h = create (List.length l) in
let rec loop = function
| [] -> Result.Ok h
| (k, v) :: xs ->
(match find h k with
| None ->
set h k v;
loop xs
| Some v' -> Error (k, v', v))
in
loop l
;;
let of_list_exn l =
match of_list l with
| Result.Ok h -> h
| Error (key, _, _) ->
Code_error.raise "Hashtbl.of_list_exn duplicate keys" [ "key", H.to_dyn key ]
;;
let add_exn t key data =
match find t key with
| None -> set t key data
| Some _ ->
Code_error.raise "Hashtbl.add_exn: key already exists" [ "key", H.to_dyn key ]
;;
let add t key data =
match find t key with
| None ->
set t key data;
Result.Ok ()
| Some p -> Result.Error p
;;
let keys t = foldi t ~init:[] ~f:(fun key _ acc -> key :: acc)
let to_dyn f t =
Dyn.Map
(foldi t ~init:[] ~f:(fun key data acc -> (H.to_dyn key, f data) :: acc)
|> List.sort ~compare:(fun (k, _) (k', _) -> Dyn.compare k k'))
;;
let to_list t = foldi t ~init:[] ~f:(fun key v acc -> (key, v) :: acc)
let filteri_inplace t ~f =
filter_map_inplace t ~f:(fun ~key ~data ->
match f ~key ~data with
| true -> Some data
| false -> None)
;;
let iter t ~f = iter t ~f:(fun ~key:_ ~data -> f data)
end

7
unikernel/duniverse/dune_/otherlibs/stdune/src/hashtbl.mli Normal file
View file

@ -0,0 +1,7 @@
module type S = Hashtbl_intf.S
module Make (Key : sig
include Hashable.S
val to_dyn : t -> Dyn.t
end) : S with type key = Key.t

25
unikernel/duniverse/dune_/otherlibs/stdune/src/hashtbl_intf.ml Normal file
View file

@ -0,0 +1,25 @@
module type S = sig
type 'a t
type key
val create : int -> 'a t
val clear : 'a t -> unit
val mem : 'a t -> key -> bool
val remove : 'a t -> key -> unit
val to_seq_values : 'a t -> 'a Seq.t
val iter : 'a t -> f:('a -> unit) -> unit
val set : 'a t -> key -> 'a -> unit
val add_exn : 'a t -> key -> 'a -> unit
val add : 'a t -> key -> 'a -> (unit, 'a) Result.t
val find : 'a t -> key -> 'a option
val find_exn : 'a t -> key -> 'a
val find_or_add : 'a t -> key -> f:(key -> 'a) -> 'a
val fold : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b
val foldi : 'a t -> init:'b -> f:(key -> 'a -> 'b -> 'b) -> 'b
val of_list_exn : (key * 'a) list -> 'a t
val keys : _ t -> key list
val to_dyn : ('v -> Dyn.t) -> 'v t -> Dyn.t
val filteri_inplace : 'a t -> f:(key:key -> data:'a -> bool) -> unit
val length : _ t -> int
val to_list : 'a t -> (key * 'a) list
end

30
unikernel/duniverse/dune_/otherlibs/stdune/src/id.ml Normal file
View file

@ -0,0 +1,30 @@
module type S = sig
type t [@@immediate]
include Comparable_intf.S with type key := t
module Table : Hashtbl.S with type key = t
val gen : unit -> t
val peek : unit -> t
val to_int : t -> int
val compare : t -> t -> Ordering.t
val equal : t -> t -> bool
val hash : t -> int
val to_dyn : t -> Dyn.t
end
module Make () : S = struct
include Int
module Table = Hashtbl.Make (Int)
let next = ref 0
let gen () =
let v = !next in
next := v + 1;
v
;;
let peek () = !next
let to_int x = x
end

25
unikernel/duniverse/dune_/otherlibs/stdune/src/id.mli Normal file
View file

@ -0,0 +1,25 @@
module type S = sig
type t [@@immediate]
include Comparable_intf.S with type key := t
module Table : Hashtbl.S with type key = t
(** Generate a new id. *)
val gen : unit -> t
(** Get the next id that would be generated, without actually generating it. *)
val peek : unit -> t
(** Convert the id to an integer. *)
val to_int : t -> int
(** Compare two ids. *)
val compare : t -> t -> Ordering.t
val equal : t -> t -> bool
val hash : t -> int
val to_dyn : t -> Dyn.t
end
(** A functor to create a new ID generator module. *)
module Make () : S

50
unikernel/duniverse/dune_/otherlibs/stdune/src/int.ml Normal file
View file

@ -0,0 +1,50 @@
module T = struct
type t = int
let compare (a : int) b : Ordering.t = if a < b then Lt else if a = b then Eq else Gt
let to_dyn x = Dyn.Int x
end
include T
include Comparable.Make (T)
let equal (a : t) b = a = b
(* This implementation (including the comment) is taken from the Base
library. *)
(* This hash was chosen from here: https://gist.github.com/badboy/6267743
It attempts to fulfill the primary goals of a non-cryptographic hash function:
- a bit change in the input should change ~1/2 of the output bits
- the output should be uniformly distributed across the output range
- inputs that are close to each other shouldn't lead to outputs that are close to
each other.
- all bits of the input are used in generating the output
In our case we also want it to be fast, non-allocating, and inlinable. *)
let[@inline always] hash (t : t) =
let t = lnot t + (t lsl 21) in
let t = t lxor (t lsr 24) in
let t = t + (t lsl 3) + (t lsl 8) in
let t = t lxor (t lsr 14) in
let t = t + (t lsl 2) + (t lsl 4) in
let t = t lxor (t lsr 28) in
t + (t lsl 31)
;;
let of_string_exn s =
match int_of_string s with
| exception Failure _ -> failwith (Printf.sprintf "of_string_exn: invalid int %S" s)
| s -> s
;;
let to_string i = string_of_int i
module Infix = Comparator.Operators (T)
let of_string s = int_of_string_opt s
let shift_left = Stdlib.Int.shift_left
let shift_right = Stdlib.Int.shift_right
let max_int = Stdlib.Int.max_int

18
unikernel/duniverse/dune_/otherlibs/stdune/src/int.mli Normal file
View file

@ -0,0 +1,18 @@
type t = int
val compare : t -> t -> Ordering.t
val equal : t -> t -> bool
val hash : t -> int
val to_dyn : t -> Dyn.t
include Comparable_intf.S with type key := t
val of_string_exn : string -> t
val of_string : string -> t option
val to_string : t -> string
module Infix : Comparator.OPS with type t = t
val shift_left : t -> t -> t
val shift_right : t -> t -> t
val max_int : t

554
unikernel/duniverse/dune_/otherlibs/stdune/src/io.ml Normal file
View file

@ -0,0 +1,554 @@
let close_in = close_in
let close_out = close_out
let close_both (ic, oc) =
match close_out oc with
| () -> close_in ic
| exception exn ->
close_in ic;
Exn.reraise exn
;;
let input_lines =
let rec loop ic acc =
match input_line ic with
| exception End_of_file -> List.rev acc
| line -> loop ic (line :: acc)
in
fun ic -> loop ic []
;;
let input_zero_from_buffer from buf =
match String.index_from_opt buf from '\x00' with
| None -> None
| Some eos -> Some (String.sub buf ~pos:from ~len:(eos - from), eos + 1)
;;
(* Note, the complexity of this function will be bad if the zero-separated
elements are much larger than the current input buffer *)
let input_zero_separated =
(* Take all the \0-terminated strings from [buf], return the scanned list and
the remainder *)
let rec scan_inputs_buf from buf acc =
(* note that from is untouched if input_zero_from_buffer returns None *)
match input_zero_from_buffer from buf with
| Some (istr, from) -> scan_inputs_buf from buf (istr :: acc)
| None ->
let total_len = String.length buf in
if total_len > from
then (
let rest = String.sub buf ~pos:from ~len:(total_len - from) in
Some rest, acc)
else None, acc
in
let ibuf_size = 65536 in
let ibuf = Bytes.create ibuf_size in
let rec input_loop ic rem acc =
let res = input ic ibuf 0 ibuf_size in
if res = 0
then (
(* end of file, check if there is a remainder, and return the results *)
match rem with
| Some rem -> List.rev (rem :: acc)
| None -> List.rev acc)
else (
(* new input, append remainder and scan it *)
let actual_input = Bytes.sub_string ibuf ~pos:0 ~len:res in
let actual_input =
match rem with
| None -> actual_input
| Some rem -> rem ^ actual_input
in
let rem, acc = scan_inputs_buf 0 actual_input acc in
input_loop ic rem acc)
in
fun ic -> input_loop ic None []
;;
let copy_channels =
let buf_len = 65536 in
let global_buf = Bytes.create buf_len in
let rec loop buf ic oc =
match input ic buf 0 buf_len with
| 0 -> ()
| n ->
output oc buf 0 n;
loop buf ic oc
in
let busy = ref false in
fun ic oc ->
if !busy
then loop (Bytes.create buf_len) ic oc
else (
busy := true;
match loop global_buf ic oc with
| () -> busy := false
| exception exn ->
busy := false;
Exn.reraise exn)
;;
let setup_copy ?(chmod = Fun.id) ~src ~dst () =
let ic = Stdlib.open_in_bin src in
let oc =
try
let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm |> chmod in
Stdlib.open_out_gen [ Open_wronly; Open_creat; Open_trunc; Open_binary ] perm dst
with
| exn ->
close_in ic;
Exn.reraise exn
in
ic, oc
;;
module Copyfile = struct
(* Bindings to mac's fast copy function. It's similar to a hardlink, except
it does COW when edited. It will also default back to regular copying if
it fails for w/e reason *)
external copyfile : string -> string -> unit = "stdune_copyfile"
external sendfile
: src:Unix.file_descr
-> dst:Unix.file_descr
-> int
-> unit
= "stdune_sendfile"
let available =
match Platform.OS.value with
| Darwin -> `Copyfile
| Linux -> `Sendfile
| _ -> `Nothing
;;
let sendfile_with_fallback =
let setup_copy ?(chmod = Fun.id) ~src ~dst () =
match Unix.openfile src [ O_RDONLY; O_CLOEXEC ] 0 with
| exception Unix.Unix_error (Unix.ENOENT, _, _) -> Error `Src_missing
| fd_src ->
(match Unix.fstat fd_src with
| exception exn ->
Unix.close fd_src;
Error (`Exn (Exn_with_backtrace.capture exn))
| src_stat ->
(match src_stat.st_kind with
| S_DIR -> Error `Src_is_a_dir
| _ ->
let open Result.O in
let+ fd_dst, src_size =
match
let dst_perm = chmod src_stat.st_perm in
Unix.openfile dst [ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ] dst_perm
with
| fd_dst -> Ok (fd_dst, src_stat.st_size)
| exception exn ->
Unix.close fd_src;
(match exn with
| Unix.Unix_error (Unix.EISDIR, _, _) -> Error `Dst_is_a_dir
| _ -> Error (`Exn (Exn_with_backtrace.capture exn)))
in
fd_src, fd_dst, src_size))
in
fun ?chmod ~src ~dst () ->
(* All of this exception translation is done for now to maintain the
same error messages as the other file copying functions.
Eventually, we should stop using exceptions for signalling these
errors. But that's a bit of a large change since there's a lot of
exception catching to audit. *)
match setup_copy ?chmod ~src ~dst () with
| Error (`Exn exn) -> Exn_with_backtrace.reraise exn
| Error `Src_is_a_dir -> raise (Sys_error "Is a directory")
| Error `Dst_is_a_dir ->
let message = Printf.sprintf "%s: Is a directory" dst in
raise (Sys_error message)
| Error `Src_missing ->
let message = Printf.sprintf "%s: No such file or directory" src in
raise (Sys_error message)
| Ok (src, dst, src_size) ->
let close_fds () =
Unix.close src;
Unix.close dst
in
(match sendfile ~src ~dst src_size with
| exception Unix.Unix_error (EINVAL, "sendfile", _) ->
Exn.protectx
(Unix.in_channel_of_descr src, Unix.out_channel_of_descr dst)
(* we make sure to close the fd's with the channel api to make
sure everything has been flushed *)
~f:(fun (ic, oc) -> copy_channels ic oc)
~finally:close_both
| () -> close_fds ()
| exception exn ->
close_fds ();
Exn.reraise exn)
;;
let copyfile ?chmod ~src ~dst () =
let src_stats =
match Unix.stat src with
| exception Unix.Unix_error (Unix.ENOENT, _, _) ->
let message = Printf.sprintf "%s: No such file or directory" src in
raise (Sys_error message)
| { st_kind = S_DIR; _ } -> raise (Sys_error "Is a directory")
| stats -> stats
in
(try copyfile src dst with
| Unix.Unix_error (Unix.EPERM, "unlink", _) ->
let message = Printf.sprintf "%s: Is a directory" dst in
raise (Sys_error message)
| Unix.Unix_error (Unix.ENOENT, "realpath", _) ->
let message = Printf.sprintf "%s: No such file or directory" src in
raise (Sys_error message));
match chmod with
| None -> ()
| Some chmod -> src_stats.st_perm |> chmod |> Unix.chmod dst
;;
let copy_file_portable ?chmod ~src ~dst () =
Exn.protectx (setup_copy ?chmod ~src ~dst ()) ~finally:close_both ~f:(fun (ic, oc) ->
copy_channels ic oc)
;;
let copy_file =
match available with
| `Sendfile -> sendfile_with_fallback
| `Copyfile -> copyfile
| `Nothing -> copy_file_portable
;;
end
module Make (Path : sig
type t
val to_string : t -> string
end) =
struct
type path = Path.t
let open_in ?(binary = true) p =
let fn = Path.to_string p in
if binary then Stdlib.open_in_bin fn else Stdlib.open_in fn
;;
let open_out ?(binary = true) ?(perm = 0o666) p =
let fn = Path.to_string p in
let flags : Stdlib.open_flag list =
[ Open_wronly; Open_creat; Open_trunc; (if binary then Open_binary else Open_text) ]
in
Stdlib.open_out_gen flags perm fn
;;
let with_file_in ?binary fn ~f = Exn.protectx (open_in ?binary fn) ~finally:close_in ~f
let with_file_in_fd fn ~f =
Exn.protectx (Unix.openfile fn [ O_RDONLY; O_CLOEXEC ] 0) ~f ~finally:Unix.close
;;
let with_file_out ?binary ?perm p ~f =
Exn.protectx (open_out ?binary ?perm p) ~finally:close_out ~f
;;
let with_lexbuf_from_file fn ~f =
with_file_in fn ~f:(fun ic ->
let lb = Lexing.from_channel ic in
lb.lex_curr_p
<- { pos_fname = Path.to_string fn; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 };
f lb)
;;
let rec eagerly_input_acc ic s ~pos ~len acc =
if len <= 0
then acc
else (
let r = input ic s pos len in
if r = 0 then acc else eagerly_input_acc ic s ~pos:(pos + r) ~len:(len - r) (acc + r))
;;
(* [eagerly_input_string ic len] tries to read [len] chars from the channel.
Unlike [really_input_string], if the file ends before [len] characters are
found, it returns the characters it was able to read instead of raising an
exception.
This can be detected by checking that the length of the resulting string is
less than [len]. *)
let eagerly_input_string ic len =
let buf = Bytes.create len in
let r = eagerly_input_acc ic buf ~pos:0 ~len 0 in
if r = len then Bytes.unsafe_to_string buf else Bytes.sub_string buf ~pos:0 ~len:r
;;
let read_all_fd =
let rec read fd buf pos left =
if left = 0
then `Ok
else (
match Unix.read fd buf pos left with
| 0 -> `Eof
| n -> read fd buf (pos + n) (left - n))
in
fun fd ->
match Unix.fstat fd with
| exception Unix.Unix_error (e, x, y) -> Error (`Unix (e, x, y))
| { Unix.st_size; _ } ->
if st_size = 0
then Ok ""
else if st_size > Sys.max_string_length
then Error `Too_big
else (
let b = Bytes.create st_size in
match read fd b 0 st_size with
| exception Unix.Unix_error (e, x, y) -> Error (`Unix (e, x, y))
| `Eof -> Error `Retry
| `Ok -> Ok (Bytes.unsafe_to_string b))
;;
let read_all_unless_large =
(* We use 65536 because that is the size of OCaml's IO buffers. *)
let chunk_size = 65536 in
(* Generic function for channels such that seeking is unsupported or
broken *)
let read_all_generic t buffer =
let rec loop () =
Buffer.add_channel buffer t chunk_size;
loop ()
in
try loop () with
| End_of_file -> Ok (Buffer.contents buffer)
in
fun t ->
(* Optimisation for regular files: if the channel supports seeking, we
compute the length of the file so that we read exactly what we need and
avoid an extra memory copy. We expect that most files Dune reads are
regular files so this optimizations seems worth it. *)
match in_channel_length t with
| exception Sys_error _ -> read_all_generic t (Buffer.create chunk_size)
| n when n > Sys.max_string_length -> Error ()
| n ->
(* For some files [in_channel_length] returns an invalid value. For
instance for files in /proc it returns [0] and on Windows the
returned value is larger than expected (it counts linebreaks as 2
chars, even in text mode).
To be robust in both directions, we: - use [eagerly_input_string]
instead of [really_input_string] in case we reach the end of the file
early - read one more character to make sure we did indeed reach the
end of the file *)
let s = eagerly_input_string t n in
(match input_char t with
| exception End_of_file -> Ok s
| c ->
(* The [+ chunk_size] is to make sure there is at least [chunk_size]
free space so that the first [Buffer.add_channel buffer t
chunk_size] in [read_all_generic] does not grow the buffer. *)
let buffer = Buffer.create (String.length s + 1 + chunk_size) in
Buffer.add_string buffer s;
Buffer.add_char buffer c;
read_all_generic t buffer)
;;
let path_to_dyn path = String.to_dyn (Path.to_string path)
let read_file_chan ?binary fn =
match with_file_in fn ~f:read_all_unless_large ?binary with
| Ok x -> x
| Error () ->
Code_error.raise
"read_file: file is larger than Sys.max_string_length"
[ "fn", path_to_dyn fn ]
;;
let read_file ?(binary = true) fn =
if binary
then
with_file_in_fd (Path.to_string fn) ~f:(fun fd ->
match read_all_fd fd with
| Ok s -> s
| Error `Retry -> read_file_chan ~binary fn
| Error `Too_big ->
Code_error.raise
"read_file: file is larger than Sys.max_string_length"
[ "fn", path_to_dyn fn ]
| Error (`Unix e) -> Dune_filesystem_stubs.Unix_error.Detailed.raise e)
else read_file_chan ~binary fn
;;
let lines_of_file fn = with_file_in fn ~f:input_lines ~binary:false
let zero_strings_of_file fn = with_file_in fn ~f:input_zero_separated ~binary:true
let write_file ?binary ?perm fn data =
with_file_out ?binary ?perm fn ~f:(fun oc -> output_string oc data)
;;
let write_lines ?binary ?perm fn lines =
with_file_out ?binary ?perm fn ~f:(fun oc ->
List.iter
~f:(fun line ->
output_string oc line;
output_string oc "\n")
lines)
;;
let read_file_and_normalize_eols fn =
if not Stdlib.Sys.win32
then read_file fn
else (
let src = read_file fn in
let len = String.length src in
let dst = Bytes.create len in
let rec find_next_crnl i =
match String.index_from src i '\r' with
| None -> None
| Some j ->
if j + 1 < len && src.[j + 1] = '\n' then Some j else find_next_crnl (j + 1)
in
let rec loop src_pos dst_pos =
match find_next_crnl src_pos with
| None ->
let len =
if len > src_pos && src.[len - 1] = '\r'
then len - 1 - src_pos
else len - src_pos
in
Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len;
Bytes.sub_string dst ~pos:0 ~len:(dst_pos + len)
| Some i ->
let len = i - src_pos in
Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len;
let dst_pos = dst_pos + len in
Bytes.set dst dst_pos '\n';
loop (i + 2) (dst_pos + 1)
in
loop 0 0)
;;
let compare_text_files fn1 fn2 =
let s1 = read_file_and_normalize_eols fn1 in
let s2 = read_file_and_normalize_eols fn2 in
String.compare s1 s2
;;
let compare_files fn1 fn2 =
let s1 = read_file fn1 in
let s2 = read_file fn2 in
String.compare s1 s2
;;
let setup_copy ?chmod ~src ~dst () =
let src = Path.to_string src in
let dst = Path.to_string dst in
setup_copy ?chmod ~src ~dst ()
;;
let copy_file ?chmod ~src ~dst () =
let src = Path.to_string src in
let dst = Path.to_string dst in
Copyfile.copy_file ?chmod ~src ~dst ()
;;
let file_line path n =
with_file_in ~binary:false path ~f:(fun ic ->
for _ = 1 to n - 1 do
ignore (input_line ic)
done;
input_line ic)
;;
let file_lines path ~start ~stop =
with_file_in ~binary:true path ~f:(fun ic ->
let rec aux acc lnum =
if lnum > stop
then List.rev acc
else if lnum < start
then (
ignore (input_line ic);
aux acc (lnum + 1))
else (
let line = input_line ic in
aux ((string_of_int lnum, line) :: acc) (lnum + 1))
in
aux [] 1)
;;
let cat ?binary ?dst fn =
let dst =
match dst with
| Some dst -> dst
| None -> stdout
in
with_file_in ?binary fn ~f:(fun ic -> copy_channels ic dst)
;;
end
include Make (Path)
module String_path = struct
include Make (struct
type t = string
let to_string x = x
end)
let copy_file = Copyfile.copyfile
end
let portable_symlink ~src ~dst =
if Stdlib.Sys.win32
then copy_file ~src ~dst ()
else (
let src =
match Path.parent dst with
| None -> Path.to_string src
| Some from -> Path.reach ~from src
in
let dst = Path.to_string dst in
match Unix.readlink dst with
| target ->
if target <> src
then (
(* @@DRA Win32 remove read-only attribute needed when symlinking
enabled *)
Unix.unlink dst;
Unix.symlink src dst)
| exception Unix.Unix_error _ -> Unix.symlink src dst)
;;
let portable_hardlink ~src ~dst =
let user_error msg =
User_error.raise
[ Pp.textf
"Sandbox creation error: cannot resolve symbolic link %S."
(Path.to_string src)
; Pp.textf "Reason: %s" msg
]
in
(* CR-someday amokhov: Instead of always falling back to copying, we could
detect if hardlinking works on Windows and if yes, use it. We do this in
the Dune cache implementation, so we can share some code. *)
match Stdlib.Sys.win32 with
| true -> copy_file ~src ~dst ()
| false ->
let src =
match Fpath.follow_symlink (Path.to_string src) with
| Ok path -> Path.of_string path
| Error Not_a_symlink -> src
| Error Max_depth_exceeded ->
user_error "Too many indirections; is this a cyclic symbolic link?"
| Error (Unix_error error) ->
user_error (Dune_filesystem_stubs.Unix_error.Detailed.to_string_hum error)
in
(try Path.link src dst with
| Unix.Unix_error (Unix.EEXIST, _, _) ->
(* CR-someday amokhov: Investigate why we need to occasionally clear the
destination (we also do this in the symlink case above). Perhaps, the
list of dependencies may have duplicates? If yes, it may be better to
filter out the duplicates first. *)
Path.unlink_exn dst;
Path.link src dst
| Unix.Unix_error (Unix.EMLINK, _, _) ->
(* If we can't make a new hard link because we reached the limit on the
number of hard links per file, we fall back to copying. We expect
that this happens very rarely (probably only for empty files). *)
copy_file ~src ~dst ())
;;

27
unikernel/duniverse/dune_/otherlibs/stdune/src/io.mli Normal file
View file

@ -0,0 +1,27 @@
(** IO operations. *)
val close_in : in_channel -> unit
val close_out : out_channel -> unit
val close_both : in_channel * out_channel -> unit
val input_lines : in_channel -> string list
val copy_channels : in_channel -> out_channel -> unit
(** Try to read everything from a channel. Returns [Error ()] if the contents
are larger than [Sys.max_string_length]. This is generally a problem only
on 32-bit systems.
Overflow detection does not happen in the following cases:
- channel is not a file (for example, a pipe)
- if the detected size is unreliable (/proc)
- race condition with another process changing the size of the underlying
file.
In these cases, an exception might be raised by [Buffer] functions. *)
val read_all_unless_large : in_channel -> (string, unit) result
include Io_intf.S with type path = Path.t
module String_path : Io_intf.S with type path = string
(** Symlink with fallback to copy on systems that don't support it. *)
val portable_symlink : src:Path.t -> dst:Path.t -> unit
(** Hardlink with fallback to copy on systems that don't support it. *)
val portable_hardlink : src:Path.t -> dst:Path.t -> unit

40
unikernel/duniverse/dune_/otherlibs/stdune/src/io_intf.ml Normal file
View file

@ -0,0 +1,40 @@
module type S = sig
type path
val open_in : ?binary:bool (* default true *) -> path -> in_channel
val open_out : ?binary:bool (* default true *) -> ?perm:int -> path -> out_channel
val with_file_in : ?binary:bool (* default true *) -> path -> f:(in_channel -> 'a) -> 'a
val with_file_out
: ?binary:bool (* default true *)
-> ?perm:int
-> path
-> f:(out_channel -> 'a)
-> 'a
val with_lexbuf_from_file : path -> f:(Lexing.lexbuf -> 'a) -> 'a
val lines_of_file : path -> string list
(** Reads zero-separated strings from a file *)
val zero_strings_of_file : path -> string list
val read_file : ?binary:bool -> path -> string
val write_file : ?binary:bool -> ?perm:int -> path -> string -> unit
val compare_files : path -> path -> Ordering.t
val compare_text_files : path -> path -> Ordering.t
val write_lines : ?binary:bool -> ?perm:int -> path -> string list -> unit
val copy_file : ?chmod:(int -> int) -> src:path -> dst:path -> unit -> unit
val setup_copy
: ?chmod:(int -> int)
-> src:path
-> dst:path
-> unit
-> in_channel * out_channel
val file_line : path -> int -> string
val file_lines : path -> start:int -> stop:int -> (string * string) list
(** reads a file and prints its contents to stdout or the specified channel *)
val cat : ?binary:bool (* default true *) -> ?dst:out_channel -> path -> unit
end

3
unikernel/duniverse/dune_/otherlibs/stdune/src/lazy.ml Normal file
View file

@ -0,0 +1,3 @@
include Stdlib.Lazy
let map t ~f = lazy (f (force t))

92
unikernel/duniverse/dune_/otherlibs/stdune/src/lexbuf.ml Normal file
View file

@ -0,0 +1,92 @@
type t = Lexing.lexbuf
module Position = struct
type t = Lexing.position
let equal
{ Lexing.pos_fname = f_a; pos_lnum = l_a; pos_bol = b_a; pos_cnum = c_a }
{ Lexing.pos_fname = f_b; pos_lnum = l_b; pos_bol = b_b; pos_cnum = c_b }
=
f_a = f_b && l_a = l_b && b_a = b_b && c_a = c_b
;;
let in_file ~fname =
{ Lexing.pos_fname = fname; pos_lnum = 1; pos_cnum = 0; pos_bol = 0 }
;;
let none = in_file ~fname:"<none>"
let to_dyn { Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum } =
let open Dyn in
Record
[ "pos_lnum", Int pos_lnum
; "pos_bol", Int pos_bol
; "pos_cnum", Int pos_cnum
; "pos_fname", String pos_fname
]
;;
let to_dyn_no_file (p : t) =
let open Dyn in
Record
[ "pos_lnum", Int p.pos_lnum; "pos_bol", Int p.pos_bol; "pos_cnum", Int p.pos_cnum ]
;;
let is_file_only { Lexing.pos_fname = _; pos_lnum; pos_cnum; pos_bol } =
pos_lnum = none.pos_lnum && pos_cnum = none.pos_cnum && pos_bol = none.pos_bol
;;
end
module Loc = struct
type t =
{ start : Lexing.position
; stop : Lexing.position
}
let of_pos (pos_fname, pos_lnum, cnum, enum) =
let start : Lexing.position = { pos_fname; pos_lnum; pos_cnum = cnum; pos_bol = 0 } in
{ start; stop = { start with pos_cnum = enum } }
;;
let map_pos { start; stop } ~f = { start = f start; stop = f stop }
let in_file ~fname =
let start = Position.in_file ~fname in
{ start; stop = start }
;;
let is_file_only t =
t.start.pos_fname = t.stop.pos_fname
&& Position.is_file_only t.start
&& Position.is_file_only t.stop
;;
let to_dyn t =
let open Dyn in
Record
[ "pos_fname", String t.start.pos_fname
; "start", Position.to_dyn_no_file t.start
; "stop", Position.to_dyn_no_file t.stop
]
;;
let compare = Poly.compare
let equal x y = Ordering.is_eq (compare x y)
let none = { start = Position.none; stop = Position.none }
end
let init (t : t) ~fname =
t.lex_curr_p <- { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }
;;
let from_string s ~fname =
let t = Lexing.from_string s in
init t ~fname;
t
;;
let from_channel ic ~fname =
let t = Lexing.from_channel ic in
init t ~fname;
t
;;

38
unikernel/duniverse/dune_/otherlibs/stdune/src/lexbuf.mli Normal file
View file

@ -0,0 +1,38 @@
(** Lexing buffer utilities *)
type t = Lexing.lexbuf
module Position : sig
type t = Lexing.position
val equal : t -> t -> bool
val in_file : fname:string -> t
val none : t
val to_dyn : t -> Dyn.t
val to_dyn_no_file : t -> Dyn.t
end
module Loc : sig
type t =
{ start : Lexing.position
; stop : Lexing.position
}
val to_dyn : t -> Dyn.t
val compare : t -> t -> Ordering.t
val equal : t -> t -> bool
val map_pos : t -> f:(Position.t -> Position.t) -> t
val in_file : fname:string -> t
val is_file_only : t -> bool
(** To be used with [__POS__] *)
val of_pos : string * int * int * int -> t
val none : t
end
(** Same as [Lexing.from_xxx] but also initialise the location to the beginning
of the given file *)
val from_string : string -> fname:string -> t
val from_channel : in_channel -> fname:string -> t

275
unikernel/duniverse/dune_/otherlibs/stdune/src/list.ml Normal file
View file

@ -0,0 +1,275 @@
include ListLabels
type 'a t = 'a list
let map ~f t = rev (rev_map ~f t)
let is_empty = function
| [] -> true
| _ -> false
;;
let is_non_empty = function
| [] -> false
| _ -> true
;;
let rev_filter_map l ~f =
let rec loop acc = function
| [] -> acc
| x :: xs ->
(match f x with
| None -> loop acc xs
| Some x -> loop (x :: acc) xs)
in
loop [] l
;;
let filter_map l ~f = rev (rev_filter_map l ~f)
let filter_opt l = filter_map ~f:Fun.id l
let filteri l ~f =
let rec filteri l i =
match l with
| [] -> []
| x :: l ->
let i' = succ i in
if f i x then x :: filteri l i' else filteri l i'
in
filteri l 0
;;
let rev_concat =
let rec loop acc = function
| [] -> acc
| x :: xs -> loop (rev_append x acc) xs
in
fun t -> loop [] t
;;
let rev_concat_map t ~f =
let rec aux f acc = function
| [] -> acc
| x :: l ->
let xs = f x in
aux f (rev_append xs acc) l
in
aux f [] t
;;
let concat_map t ~f = rev (rev_concat_map t ~f)
let rev_partition_map =
let rec loop l accl accr ~f =
match l with
| [] -> accl, accr
| x :: l ->
(match (f x : (_, _) Either.t) with
| Left y -> loop l (y :: accl) accr ~f
| Right y -> loop l accl (y :: accr) ~f)
in
fun l ~f -> loop l [] [] ~f
;;
let partition_map l ~f =
let l, r = rev_partition_map l ~f in
rev l, rev r
;;
type ('a, 'b) skip_or_either =
| Skip
| Left of 'a
| Right of 'b
let rev_filter_partition_map =
let rec loop l accl accr ~f =
match l with
| [] -> accl, accr
| x :: l ->
(match f x with
| Skip -> loop l accl accr ~f
| Left y -> loop l (y :: accl) accr ~f
| Right y -> loop l accl (y :: accr) ~f)
in
fun l ~f -> loop l [] [] ~f
;;
let filter_partition_map l ~f =
let l, r = rev_filter_partition_map l ~f in
rev l, rev r
;;
let rec find_map l ~f =
match l with
| [] -> None
| x :: l ->
(match f x with
| None -> find_map l ~f
| Some _ as res -> res)
;;
let findi l ~f =
let rec findi acc l ~f =
match l with
| [] -> None
| x :: l -> if f x then Some (x, acc) else findi (acc + 1) l ~f
in
findi 0 l ~f
;;
let rec find l ~f =
match l with
| [] -> None
| x :: l -> if f x then Some x else find l ~f
;;
let find_exn l ~f =
match find l ~f with
| Some x -> x
| None -> Code_error.raise "List.find_exn" []
;;
let rec last = function
| [] -> None
| [ x ] -> Some x
| _ :: xs -> last xs
;;
let destruct_last =
let rec loop acc = function
| [] -> None
| [ x ] -> Some (rev acc, x)
| x :: xs -> loop (x :: acc) xs
in
fun xs -> loop [] xs
;;
let remove_last_exn t =
match destruct_last t with
| Some (t, _) -> t
| None -> Code_error.raise "remove_last_exn: empty list" []
;;
let sort t ~compare = sort t ~cmp:(fun a b -> Ordering.to_int (compare a b))
let stable_sort t ~compare = stable_sort t ~cmp:(fun a b -> Ordering.to_int (compare a b))
let sort_uniq t ~compare =
Stdlib.List.sort_uniq (fun a b -> Ordering.to_int (compare a b)) t
;;
let rec compare a b ~compare:f : Ordering.t =
match a, b with
| [], [] -> Eq
| [], _ :: _ -> Lt
| _ :: _, [] -> Gt
| x :: a, y :: b ->
(match (f x y : Ordering.t) with
| Eq -> compare a b ~compare:f
| ne -> ne)
;;
let rec assoc t x =
match t with
| [] -> None
| (k, v) :: t -> if x = k then Some v else assoc t x
;;
let singleton x = [ x ]
let rec nth t i =
match t, i with
| [], _ -> None
| x :: _, 0 -> Some x
| _ :: xs, i -> nth xs (i - 1)
;;
let physically_equal = Stdlib.( == )
let init =
let rec loop acc i n f = if i = n then rev acc else loop (f i :: acc) (i + 1) n f in
fun n ~f -> loop [] 0 n f
;;
let hd_opt = function
| [] -> None
| x :: _ -> Some x
;;
let rec equal eq xs ys =
match xs, ys with
| [], [] -> true
| x :: xs, y :: ys -> eq x y && equal eq xs ys
| _, _ -> false
;;
let hash f xs = Stdlib.Hashtbl.hash (map ~f xs)
let cons x xs = x :: xs
(* copy&paste from [base] *)
let fold_map t ~init ~f =
let acc = ref init in
let result =
map t ~f:(fun x ->
let new_acc, y = f !acc x in
acc := new_acc;
y)
in
!acc, result
;;
let unzip l = fold_right ~init:([], []) ~f:(fun (x, y) (xs, ys) -> x :: xs, y :: ys) l
let rec for_all2 x y ~f =
match x, y with
| [], [] -> Ok true
| x :: xs, y :: ys -> if f x y then for_all2 xs ys ~f else Ok false
| _, _ -> Error `Length_mismatch
;;
let reduce xs ~f =
match xs with
| [] -> None
| init :: xs -> Some (fold_left xs ~init ~f)
;;
let min xs ~f = reduce xs ~f:(Ordering.min f)
let max xs ~f = reduce xs ~f:(Ordering.max f)
let mem t a ~equal = exists t ~f:(equal a)
(* copy&paste from [base] *)
let split_while xs ~f =
let rec loop acc = function
| hd :: tl when f hd -> loop (hd :: acc) tl
| t -> rev acc, t
in
loop [] xs
;;
let truncate ~max_length xs =
let rec loop acc length = function
| [] -> `Not_truncated (rev acc)
| _ :: _ when length >= max_length -> `Truncated (rev acc)
| hd :: tl -> loop (hd :: acc) (length + 1) tl
in
loop [] 0 xs
;;
let intersperse xs ~sep =
let rec loop acc = function
| [] -> rev acc
| [ x ] -> rev (x :: acc)
| x :: xs -> loop (sep :: x :: acc) xs
in
loop [] xs
;;
let rec partition_three xs ~f =
match xs with
| [] -> [], [], []
| first :: rest ->
let xs, ys, zs = partition_three ~f rest in
(match f first with
| `Left x -> x :: xs, ys, zs
| `Middle y -> xs, y :: ys, zs
| `Right z -> xs, ys, z :: zs)
;;

76
unikernel/duniverse/dune_/otherlibs/stdune/src/list.mli Normal file
View file

@ -0,0 +1,76 @@
include module type of struct
include ListLabels
end
(* ocaml/ocaml#1892 "Allow shadowing of items coming from an include" helps
making this work in 4.08, as OCaml now includes a `List.t` type. *)
type 'a t = 'a list
val rev_concat : 'a list list -> 'a list
val is_empty : _ t -> bool
val is_non_empty : _ t -> bool
val rev_filter_map : 'a t -> f:('a -> 'b option) -> 'b t
val filter_map : 'a t -> f:('a -> 'b option) -> 'b t
val filter_opt : 'a option t -> 'a t
val filteri : 'a t -> f:(int -> 'a -> bool) -> 'a t
val rev_concat_map : 'a t -> f:('a -> 'b t) -> 'b t
val concat_map : 'a t -> f:('a -> 'b t) -> 'b t
val partition_map : 'a t -> f:('a -> ('b, 'c) Either.t) -> 'b t * 'c t
val rev_partition_map : 'a t -> f:('a -> ('b, 'c) Either.t) -> 'b t * 'c t
val partition_three
: 'a t
-> f:('a -> [ `Left of 'x | `Middle of 'y | `Right of 'z ])
-> 'x list * 'y list * 'z list
type ('a, 'b) skip_or_either =
| Skip
| Left of 'a
| Right of 'b
val filter_partition_map : 'a t -> f:('a -> ('b, 'c) skip_or_either) -> 'b t * 'c t
val rev_filter_partition_map : 'a t -> f:('a -> ('b, 'c) skip_or_either) -> 'b t * 'c t
val find : 'a t -> f:('a -> bool) -> 'a option
val findi : 'a t -> f:('a -> bool) -> ('a * int) option
val find_exn : 'a t -> f:('a -> bool) -> 'a
val find_map : 'a t -> f:('a -> 'b option) -> 'b option
val last : 'a t -> 'a option
val destruct_last : 'a t -> ('a list * 'a) option
(** remove the last element in the list. The list must be non empty *)
val remove_last_exn : 'a t -> 'a t
val sort : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t
val stable_sort : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t
val sort_uniq : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t
val compare : 'a t -> 'a t -> compare:('a -> 'a -> Ordering.t) -> Ordering.t
val assoc : ('a * 'b) t -> 'a -> 'b option
val singleton : 'a -> 'a t
val nth : 'a t -> int -> 'a option
val physically_equal : 'a t -> 'a t -> bool
val init : int -> f:(int -> 'a) -> 'a list
val hd_opt : 'a t -> 'a option
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val hash : ('a -> int) -> 'a list -> int
val cons : 'a -> 'a t -> 'a t
val fold_map : 'a list -> init:'b -> f:('b -> 'a -> 'b * 'c) -> 'b * 'c list
val unzip : ('a * 'b) t -> 'a t * 'b t
val for_all2
: 'a list
-> 'b list
-> f:('a -> 'b -> bool)
-> (bool, [ `Length_mismatch ]) result
val reduce : 'a list -> f:('a -> 'a -> 'a) -> 'a option
val min : 'a list -> f:('a -> 'a -> Ordering.t) -> 'a option
val max : 'a list -> f:('a -> 'a -> Ordering.t) -> 'a option
val mem : 'a list -> 'a -> equal:('a -> 'a -> bool) -> bool
val split_while : 'a t -> f:('a -> bool) -> 'a t * 'a t
val truncate : max_length:int -> 'a t -> [> `Not_truncated of 'a t | `Truncated of 'a t ]
val of_seq : 'a Seq.t -> 'a t
val to_seq : 'a t -> 'a Seq.t
(** [list_intersperse t ~sep] returns [t] with [sep] inserted between each pair
of consecutive values. *)
val intersperse : 'a t -> sep:'a -> 'a t

161
unikernel/duniverse/dune_/otherlibs/stdune/src/loc.ml Normal file
View file

@ -0,0 +1,161 @@
include Loc0
module O = Comparable.Make (Loc0)
include O
let in_file p = Lexbuf.Loc.in_file ~fname:(Path.to_string p) |> of_lexbuf_loc
let in_dir = in_file
let drop_position (t : t) =
let pos = Lexbuf.Position.in_file ~fname:(start t).pos_fname in
create ~start:pos ~stop:pos
;;
let of_lexbuf lexbuf : t =
create ~start:(Lexing.lexeme_start_p lexbuf) ~stop:(Lexing.lexeme_end_p lexbuf)
;;
let of_pos pos = Lexbuf.Loc.of_pos pos |> of_lexbuf_loc
let to_file_colon_line t =
let start = start t in
Printf.sprintf "%s:%d" start.pos_fname start.pos_lnum
;;
let to_dyn_hum t : Dyn.t = String (to_file_colon_line t)
let pp_file_colon_line t = Pp.verbatim (to_file_colon_line t)
let pp_left_pad n s =
let needed_spaces = n - String.length s in
Pp.verbatim (if needed_spaces > 0 then String.make needed_spaces ' ' ^ s else s)
;;
let pp_line padding_width (lnum, l) =
let open Pp.O in
pp_left_pad padding_width lnum ++ Pp.verbatim " | " ++ Pp.verbatim l ++ Pp.newline
;;
type tag = Loc
let pp_file_excerpt ~context_lines ~max_lines_to_print_in_full loc : tag Pp.t =
let start = start loc in
let stop = stop loc in
let start_c = start.pos_cnum - start.pos_bol in
let stop_c = stop.pos_cnum - start.pos_bol in
let file = start.pos_fname in
let pp_file_excerpt () =
let open Result.O in
match if start.pos_lnum <> stop.pos_lnum then `Multiline else `Singleline with
| `Singleline ->
let line_num = start.pos_lnum in
let line_num_str = string_of_int line_num in
let padding_width = String.length line_num_str in
let* line = Result.try_with (fun () -> Io.String_path.file_line file line_num) in
let len = stop_c - start_c in
let open Pp.O in
Ok
(pp_line padding_width (line_num_str, line)
++ pp_left_pad (stop_c + padding_width + 3) (String.make len '^')
++ Pp.newline)
| `Multiline ->
let get_padding lines =
let lnum, _ = Option.value_exn (List.last lines) in
String.length lnum
in
let print_ellipsis padding_width =
(* We add 2 to the width of max line to account for the extra space and
the `|` character at the end of a line number *)
let line = String.make (padding_width + 2) '.' in
let open Pp.O in
Pp.verbatim line ++ Pp.newline
in
let print_lines lines padding_width =
Pp.concat_map lines ~f:(pp_line padding_width)
in
let file_lines ~start ~stop =
Result.try_with (fun () -> Io.String_path.file_lines file ~start ~stop)
in
let num_lines = stop.pos_lnum - start.pos_lnum in
if num_lines <= max_lines_to_print_in_full
then
let+ lines = file_lines ~start:start.pos_lnum ~stop:stop.pos_lnum in
print_lines lines (get_padding lines)
else
(* We need to send the padding width from the last four lines so the two
blocks of lines align if they have different number of digits in
their line numbers *)
let* first_shown_lines =
file_lines ~start:start.pos_lnum ~stop:(start.pos_lnum + context_lines)
in
let+ last_shown_lines =
file_lines ~start:(stop.pos_lnum - context_lines) ~stop:stop.pos_lnum
in
let padding_width = get_padding last_shown_lines in
let open Pp.O in
print_lines first_shown_lines padding_width
++ print_ellipsis padding_width
++ print_lines last_shown_lines padding_width
in
let whole_file = start_c = 0 && stop_c = 0 in
if whole_file
then Pp.nop
else (
match
let open Result.O in
let* exists = Result.try_with (fun () -> Sys.file_exists start.pos_fname) in
if exists then pp_file_excerpt () else Result.Ok Pp.nop
with
| Ok pp -> pp
| Error exn ->
let backtrace = Printexc.get_backtrace () in
Format.eprintf
"Raised when trying to print location %s@.%a@."
(Loc0.to_dyn loc |> Dyn.to_string)
(Exn.pp_uncaught ~backtrace)
exn;
Pp.nop)
;;
let pp loc =
let start = start loc in
let stop = stop loc in
let start_c = start.pos_cnum - start.pos_bol in
let stop_c = stop.pos_cnum - start.pos_bol in
let lnum =
if start.pos_lnum = stop.pos_lnum
then Printf.sprintf "line %d" start.pos_lnum
else Printf.sprintf "lines %d-%d" start.pos_lnum stop.pos_lnum
in
let open Pp.O in
Pp.tag
Loc
(Pp.verbatim
(Printf.sprintf
"File \"%s\", %s, characters %d-%d:"
start.pos_fname
lnum
start_c
stop_c))
++ Pp.newline
++ pp_file_excerpt ~context_lines:2 ~max_lines_to_print_in_full:10 loc
;;
let on_same_line loc1 loc2 =
let start1 = start loc1 in
let start2 = start loc2 in
let same_file = String.equal start1.pos_fname start2.pos_fname in
let same_line = Int.equal start1.pos_lnum start2.pos_lnum in
same_file && same_line
;;
let span (a : t) (b : t) =
let earliest_start =
if (start a).pos_cnum < (start b).pos_cnum then start a else start b
in
let latest_stop = if (stop a).pos_cnum > (stop b).pos_cnum then stop a else stop b in
create ~start:earliest_start ~stop:latest_stop
;;
let rec render ppf pp =
Pp.to_fmt_with_tags ppf pp ~tag_handler:(fun ppf Loc pp ->
Format.fprintf ppf "@{<loc>%a@}" render pp)
;;

29
unikernel/duniverse/dune_/otherlibs/stdune/src/loc.mli Normal file
View file

@ -0,0 +1,29 @@
include module type of struct
include Loc0
end
module Map : Map_intf.S with type key := t
val in_file : Path.t -> t
val in_dir : Path.t -> t
val none : t
val is_none : t -> bool
val drop_position : t -> t
val of_lexbuf : Lexing.lexbuf -> t
val to_dyn : t -> Dyn.t
(** To be used with [__POS__] *)
val of_pos : string * int * int * int -> t
val to_file_colon_line : t -> string
val pp_file_colon_line : t -> 'a Pp.t
val to_dyn_hum : t -> Dyn.t
type tag = Loc
val pp : t -> tag Pp.t
val render : Format.formatter -> tag Pp.t -> unit
val on_same_line : t -> t -> bool
val compare : t -> t -> Ordering.t
val span : t -> t -> t
val set_start_to_stop : t -> t

102
unikernel/duniverse/dune_/otherlibs/stdune/src/loc0.ml Normal file
View file

@ -0,0 +1,102 @@
module Position = Lexbuf.Position
type t =
| No_loc
| In_file of string
| Lexbuf_loc of Lexbuf.Loc.t
| Same_file of
{ pos_fname : string
; start : Compact_position.t
; stop : Compact_position.t
}
| Same_line of
{ pos_fname : string
; loc : Compact_position.Same_line_loc.t
}
open Lexbuf.Loc
let to_lexbuf_loc = function
| No_loc -> Lexbuf.Loc.none
| Lexbuf_loc loc -> loc
| In_file fname -> Lexbuf.Loc.in_file ~fname
| Same_file { pos_fname; start; stop } ->
let start = Compact_position.to_position start ~fname:pos_fname in
let stop = Compact_position.to_position stop ~fname:pos_fname in
{ Lexbuf.Loc.start; stop }
| Same_line { pos_fname; loc } ->
Compact_position.Same_line_loc.to_loc loc ~fname:pos_fname
;;
let in_file ~fname = In_file fname
let of_lexbuf_loc loc =
if Lexbuf.Loc.(equal none loc)
then No_loc
else if Lexbuf.Loc.is_file_only loc
then In_file loc.start.pos_fname
else (
let pos_fname = loc.start.pos_fname in
match Compact_position.of_loc loc with
| Same_line loc -> Same_line { pos_fname; loc }
| Loc { start; stop } -> Same_file { pos_fname; start; stop }
| Loc_does_not_fit -> Lexbuf_loc loc)
;;
let start = function
| No_loc -> Lexbuf.Loc.none.start
| Lexbuf_loc loc -> loc.start
| In_file fname -> Position.in_file ~fname
| Same_file { pos_fname; start; stop = _ } ->
Compact_position.to_position start ~fname:pos_fname
| Same_line { pos_fname; loc } ->
Compact_position.Same_line_loc.start loc ~fname:pos_fname
;;
let stop = function
| No_loc -> Lexbuf.Loc.none.stop
| Lexbuf_loc loc -> loc.stop
| In_file fname -> Position.in_file ~fname
| Same_file { pos_fname; stop; start = _ } ->
Compact_position.to_position stop ~fname:pos_fname
| Same_line { pos_fname; loc } ->
Compact_position.Same_line_loc.stop loc ~fname:pos_fname
;;
let compare = Poly.compare
let equal = Poly.equal
let none = No_loc
let is_none = function
| No_loc -> true
| _ -> false
;;
let to_dyn t = Lexbuf.Loc.to_dyn (to_lexbuf_loc t)
let set_stop t stop = of_lexbuf_loc { (to_lexbuf_loc t) with stop }
let set_start t start = of_lexbuf_loc { (to_lexbuf_loc t) with start }
let create ~start ~stop = of_lexbuf_loc { start; stop }
let map_pos t ~f = to_lexbuf_loc t |> Lexbuf.Loc.map_pos ~f |> of_lexbuf_loc
let set_start_to_stop = function
| (No_loc | In_file _) as t -> t
| Lexbuf_loc loc -> of_lexbuf_loc { loc with start = loc.stop }
| Same_file t -> Same_file { t with start = t.stop }
| Same_line t ->
let loc = Compact_position.Same_line_loc.set_start_to_stop t.loc in
Same_line { t with loc }
;;
let start_pos_cnum = function
| No_loc | In_file _ -> Lexbuf.Loc.none.start.pos_cnum
| Lexbuf_loc loc -> loc.start.pos_cnum
| Same_file t -> Compact_position.cnum t.start
| Same_line t -> Compact_position.Same_line_loc.start_cnum t.loc
;;
let stop_pos_cnum = function
| No_loc | In_file _ -> Lexbuf.Loc.none.stop.pos_cnum
| Lexbuf_loc loc -> loc.stop.pos_cnum
| Same_file t -> Compact_position.cnum t.stop
| Same_line t -> Compact_position.Same_line_loc.stop_cnum t.loc
;;

19
unikernel/duniverse/dune_/otherlibs/stdune/src/loc0.mli Normal file
View file

@ -0,0 +1,19 @@
type t
val to_lexbuf_loc : t -> Lexbuf.Loc.t
val of_lexbuf_loc : Lexbuf.Loc.t -> t
val start : t -> Lexing.position
val map_pos : t -> f:(Lexing.position -> Lexing.position) -> t
val create : start:Lexing.position -> stop:Lexing.position -> t
val in_file : fname:string -> t
val set_stop : t -> Lexing.position -> t
val set_start : t -> Lexing.position -> t
val stop : t -> Lexing.position
val compare : t -> t -> Ordering.t
val equal : t -> t -> bool
val none : t
val is_none : t -> bool
val to_dyn : t -> Dyn.t
val set_start_to_stop : t -> t
val start_pos_cnum : t -> int
val stop_pos_cnum : t -> int

293
unikernel/duniverse/dune_/otherlibs/stdune/src/map.ml Normal file
View file

@ -0,0 +1,293 @@
module type S = Map_intf.S
module type Key = Map_intf.Key
module Make (Key : Key) : S with type key = Key.t = struct
include MoreLabels.Map.Make (struct
type t = Key.t
let compare a b = Ordering.to_int (Key.compare a b)
end)
let find key t = find_opt t key
let mem t k = mem k t
let set t k v = add ~key:k ~data:v t
let update t k ~f = update ~key:k ~f t
let add_exn t key v =
update t key ~f:(function
| None -> Some v
| Some _ ->
Code_error.raise "Map.add_exn: key already exists" [ "key", Key.to_dyn key ])
;;
let add (type e) (t : e t) key v =
let module M = struct
exception Found of e
end
in
try
Result.Ok
(update t key ~f:(function
| None -> Some v
| Some e -> raise_notrace (M.Found e)))
with
| M.Found e -> Error e
;;
let remove t k = remove k t
let add_multi t key x =
let l = Option.value (find t key) ~default:[] in
set t key (x :: l)
;;
let merge a b ~f = merge a b ~f
let union a b ~f = union a b ~f
let union_all maps ~f =
match maps with
| [] -> empty
| init :: maps -> List.fold_left maps ~init ~f:(fun acc map -> union acc map ~f)
;;
let union_exn a b =
union a b ~f:(fun key _ _ ->
Code_error.raise
"Map.union_exn: a key appears in both maps"
[ "key", Key.to_dyn key ])
;;
let compare a b ~compare:f =
compare a b ~cmp:(fun a b -> Ordering.to_int (f a b)) |> Ordering.of_int
;;
let equal a b ~equal:f = equal a b ~cmp:f
let iteri t ~f = iter t ~f:(fun ~key ~data -> f key data)
let iter t ~f = iteri t ~f:(fun _ x -> f x)
let iter2 a b ~f =
ignore
(merge a b ~f:(fun key a b ->
f key a b;
None)
: _ t)
;;
let foldi t ~init ~f = fold t ~init ~f:(fun ~key ~data acc -> f key data acc)
let fold t ~init ~f = foldi t ~init ~f:(fun _ x acc -> f x acc)
let for_alli t ~f = for_all t ~f
let for_all t ~f = for_alli t ~f:(fun _ x -> f x)
let existsi t ~f = exists t ~f
let exists t ~f = existsi t ~f:(fun _ x -> f x)
let filteri t ~f = filter t ~f
let filter t ~f = filteri t ~f:(fun _ x -> f x)
let partitioni t ~f = partition t ~f
let partition t ~f = partitioni t ~f:(fun _ x -> f x)
let partition_map t ~f =
foldi t ~init:(empty, empty) ~f:(fun i x (l, r) ->
match f x with
| Either.Left e -> set l i e, r
| Right e -> l, set r i e)
;;
let to_list = bindings
let to_list_map t ~f = foldi t ~init:[] ~f:(fun k v acc -> f k v :: acc) |> List.rev
let of_list =
let rec loop acc = function
| [] -> Result.Ok acc
| (k, v) :: l ->
(match find acc k with
| None -> loop (set acc k v) l
| Some v_old -> Error (k, v_old, v))
in
fun l -> loop empty l
;;
let of_list_map =
let rec loop f acc = function
| [] -> Result.Ok acc
| x :: l ->
let k, v = f x in
if mem acc k then Error k else loop f (set acc k v) l
in
fun l ~f ->
match loop f empty l with
| Result.Ok _ as x -> x
| Error k ->
(match
List.filter l ~f:(fun x ->
match Key.compare (fst (f x)) k with
| Eq -> true
| _ -> false)
with
| x :: y :: _ -> Error (k, x, y)
| _ -> assert false)
;;
let of_list_map_exn t ~f =
match of_list_map t ~f with
| Result.Ok x -> x
| Error (key, _, _) ->
Code_error.raise "Map.of_list_map_exn" [ "key", Key.to_dyn key ]
;;
let of_list_exn l =
match of_list l with
| Result.Ok x -> x
| Error (key, _, _) -> Code_error.raise "Map.of_list_exn" [ "key", Key.to_dyn key ]
;;
let of_list_reduce l ~f =
List.fold_left l ~init:empty ~f:(fun acc (key, data) ->
match find acc key with
| None -> set acc key data
| Some x -> set acc key (f x data))
;;
let of_list_fold l ~init ~f =
List.fold_left l ~init:empty ~f:(fun acc (key, data) ->
let x = Option.value (find acc key) ~default:init in
set acc key (f x data))
;;
let of_list_reducei l ~f =
List.fold_left l ~init:empty ~f:(fun acc (key, data) ->
match find acc key with
| None -> set acc key data
| Some x -> set acc key (f key x data))
;;
let of_list_multi l =
List.fold_left (List.rev l) ~init:empty ~f:(fun acc (key, data) ->
add_multi acc key data)
;;
let of_list_unit =
let rec loop acc = function
| [] -> acc
| k :: l -> loop (set acc k ()) l
in
fun l -> loop empty l
;;
let keys t = foldi t ~init:[] ~f:(fun k _ l -> k :: l) |> List.rev
let values t = foldi t ~init:[] ~f:(fun _ v l -> v :: l) |> List.rev
let find_exn t key =
match find_opt key t with
| Some v -> v
| None ->
Code_error.raise
"Map.find_exn: failed to find key"
[ "key", Key.to_dyn key; "keys", Dyn.list Key.to_dyn (keys t) ]
;;
let min_binding = min_binding_opt
let max_binding = max_binding_opt
let choose = choose_opt
let split k t = split t k
let map t ~f = map t ~f
let mapi t ~f = mapi t ~f
let fold_mapi t ~init ~f =
let acc = ref init in
let result =
mapi t ~f:(fun i x ->
let new_acc, y = f i !acc x in
acc := new_acc;
y)
in
!acc, result
;;
let filter_mapi t ~f =
merge t empty ~f:(fun key data _always_none ->
match data with
| None -> assert false
| Some data -> f key data)
;;
let filter_map t ~f = filter_mapi t ~f:(fun _ x -> f x)
let filter_opt t = filter_map t ~f:Fun.id
let superpose =
let f _ x _ = Some x in
fun a b -> union a b ~f
;;
let is_subset t ~of_ ~f =
let not_subset () = raise_notrace Exit in
match
merge t of_ ~f:(fun _dir t of_ ->
match t with
| None -> None
| Some t ->
(match of_ with
| None -> not_subset ()
| Some of_ -> if f t ~of_ then None else not_subset ()))
with
| (_ : _ t) -> true
| exception Exit -> false
;;
exception Found of Key.t
let find_key t ~f =
match iteri t ~f:(fun key _ -> if f key then raise_notrace (Found key) else ()) with
| () -> None
| exception Found e -> Some e
;;
let to_dyn f t = Dyn.Map (to_list t |> List.map ~f:(fun (k, v) -> Key.to_dyn k, f v))
let to_seq = to_seq
module Multi = struct
type nonrec 'a t = 'a list t
let rev_union m1 m2 = union m1 m2 ~f:(fun _ l1 l2 -> Some (List.rev_append l1 l2))
let cons t k x =
update t k ~f:(function
| None -> Some [ x ]
| Some xs -> Some (x :: xs))
;;
let find t k = Option.value (find t k) ~default:[]
let add_all t k = function
| [] -> t
| entries ->
update t k ~f:(fun v ->
Some
(match v with
| None -> entries
| Some x -> List.append x entries))
;;
let find_elt : type a. a t -> f:(a -> bool) -> (key * a) option =
fun m ~f ->
let exception Found of (key * a) in
try
let check_found k e = if f e then raise_notrace (Found (k, e)) in
iteri ~f:(fun k -> List.iter ~f:(check_found k)) m;
None
with
| Found p -> Some p
;;
let to_flat_list t = fold t ~init:[] ~f:List.rev_append
let map t ~f = map t ~f:(fun l -> List.map ~f l)
let parent_equal = equal
let equal t t' ~equal =
parent_equal
~equal:(fun l l' -> Result.value ~default:false @@ List.for_all2 ~f:equal l l')
t
t'
;;
let to_dyn a_to_dyn t = to_dyn (Dyn.list a_to_dyn) t
end
end

4
unikernel/duniverse/dune_/otherlibs/stdune/src/map.mli Normal file
View file

@ -0,0 +1,4 @@
module type S = Map_intf.S
module type Key = Map_intf.Key
module Make (Key : Key) : S with type key = Key.t

116
unikernel/duniverse/dune_/otherlibs/stdune/src/map_intf.ml Normal file
View file

@ -0,0 +1,116 @@
module type Key = sig
include Comparator.S
val to_dyn : t -> Dyn.t
end
module type S = sig
type key
type +'a t
val empty : 'a t
val is_empty : 'a t -> bool
val mem : 'a t -> key -> bool
val set : 'a t -> key -> 'a -> 'a t
val add : 'a t -> key -> 'a -> ('a t, 'a) Result.t
val add_exn : 'a t -> key -> 'a -> 'a t
val update : 'a t -> key -> f:('a option -> 'a option) -> 'a t
val singleton : key -> 'a -> 'a t
val remove : 'a t -> key -> 'a t
val add_multi : 'a list t -> key -> 'a -> 'a list t
val merge : 'a t -> 'b t -> f:(key -> 'a option -> 'b option -> 'c option) -> 'c t
val union : 'a t -> 'a t -> f:(key -> 'a -> 'a -> 'a option) -> 'a t
val union_all : 'a t list -> f:(key -> 'a -> 'a -> 'a option) -> 'a t
(** Like [union] but raises a code error if a key appears in both maps. *)
val union_exn : 'a t -> 'a t -> 'a t
(** [superpose a b] is [a] augmented with bindings of [b] that are not in [a]. *)
val superpose : 'a t -> 'a t -> 'a t
val compare : 'a t -> 'a t -> compare:('a -> 'a -> Ordering.t) -> Ordering.t
val equal : 'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool
val iter : 'a t -> f:('a -> unit) -> unit
val iteri : 'a t -> f:(key -> 'a -> unit) -> unit
val iter2 : 'a t -> 'b t -> f:(key -> 'a option -> 'b option -> unit) -> unit
val fold : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b
val foldi : 'a t -> init:'b -> f:(key -> 'a -> 'b -> 'b) -> 'b
val for_all : 'a t -> f:('a -> bool) -> bool
val for_alli : 'a t -> f:(key -> 'a -> bool) -> bool
val exists : 'a t -> f:('a -> bool) -> bool
val existsi : 'a t -> f:(key -> 'a -> bool) -> bool
val filter : 'a t -> f:('a -> bool) -> 'a t
val filteri : 'a t -> f:(key -> 'a -> bool) -> 'a t
val partition : 'a t -> f:('a -> bool) -> 'a t * 'a t
val partition_map : 'a t -> f:('a -> ('x, 'y) Either.t) -> 'x t * 'y t
val partitioni : 'a t -> f:(key -> 'a -> bool) -> 'a t * 'a t
val cardinal : 'a t -> int
val to_list : 'a t -> (key * 'a) list
val to_list_map : 'a t -> f:(key -> 'a -> 'b) -> 'b list
val of_list : (key * 'a) list -> ('a t, key * 'a * 'a) Result.t
val of_list_map : 'a list -> f:('a -> key * 'b) -> ('b t, key * 'a * 'a) Result.t
val of_list_map_exn : 'a list -> f:('a -> key * 'b) -> 'b t
val of_list_exn : (key * 'a) list -> 'a t
val of_list_multi : (key * 'a) list -> 'a list t
val of_list_reduce : (key * 'a) list -> f:('a -> 'a -> 'a) -> 'a t
val of_list_reducei : (key * 'a) list -> f:(key -> 'a -> 'a -> 'a) -> 'a t
val of_list_unit : key list -> unit t
(** Return a map of [(k, v)] bindings such that:
{[
v = f init @@ f v1 @@ fv2 @@ ... @@ f vn
]}
where [v1], [v2], ... [vn] are the values associated to [k] in the input
list, in the order in which they appear. This is essentially a more
efficient version of:
{[
of_list_multi l |> map ~f:(List.fold_left ~init ~f)
]} *)
val of_list_fold : (key * 'a) list -> init:'b -> f:('b -> 'a -> 'b) -> 'b t
val keys : 'a t -> key list
val values : 'a t -> 'a list
val min_binding : 'a t -> (key * 'a) option
val max_binding : 'a t -> (key * 'a) option
val choose : 'a t -> (key * 'a) option
val split : 'a t -> key -> 'a t * 'a option * 'a t
val find : 'a t -> key -> 'a option
val find_exn : 'a t -> key -> 'a
val find_key : 'a t -> f:(key -> bool) -> key option
val map : 'a t -> f:('a -> 'b) -> 'b t
val mapi : 'a t -> f:(key -> 'a -> 'b) -> 'b t
val fold_mapi : 'a t -> init:'acc -> f:(key -> 'acc -> 'a -> 'acc * 'b) -> 'acc * 'b t
val filter_map : 'a t -> f:('a -> 'b option) -> 'b t
val filter_mapi : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
val filter_opt : 'a option t -> 'a t
(** [is_subset t ~of_ ~f] is [true] iff all keys in [t] are in [of_] and [f]
is [true] for all keys that are in both. *)
val is_subset : 'a t -> of_:'b t -> f:('a -> of_:'b -> bool) -> bool
val to_dyn : ('a -> Dyn.t) -> 'a t -> Dyn.t
val to_seq : 'a t -> (key * 'a) Seq.t
module Multi : sig
type nonrec 'a t = 'a list t
val rev_union : 'a t -> 'a t -> 'a t
val cons : 'a t -> key -> 'a -> 'a t
val find : 'a t -> key -> 'a list
val add_all : 'a t -> key -> 'a list -> 'a t
(** [find_elt m ~f] linearly traverses the map [m] and the contained lists
to find the first element [e] (in a list [l], mapped to key [k]) such
that [f e = true]. If such an [e] is found then the function returns
[Some (k,e)], otherwise it returns [None]. *)
val find_elt : 'a t -> f:('a -> bool) -> (key * 'a) option
val to_flat_list : 'a t -> 'a list
val equal : 'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool
val map : 'a t -> f:('a -> 'b) -> 'b t
val to_dyn : ('a -> Dyn.t) -> 'a t -> Dyn.t
end
end

135
unikernel/duniverse/dune_/otherlibs/stdune/src/monad.ml Normal file
View file

@ -0,0 +1,135 @@
module type Basic = Monad_intf.Basic
module type S = Monad_intf.S
module type List = Monad_intf.List
module type Option = Monad_intf.Option
module type Result = Monad_intf.Result
module Make (M : Basic) = struct
include M
let map t ~f = bind t ~f:(fun x -> return (f x))
module O = struct
let ( >>= ) t f = bind t ~f
let ( >>| ) t f = map t ~f
let ( >>> ) a b = bind a ~f:(fun () -> b)
let ( let+ ) t f = map t ~f
let ( and+ ) x y =
let open M in
x >>= fun x -> y >>= fun y -> return (x, y)
;;
let ( let* ) t f = bind t ~f
let ( and* ) = ( and+ )
end
end
[@@inline always]
module Id = Make (struct
type 'a t = 'a
let return x = x
let bind x ~f = f x
end)
module List (M : S) = struct
open M
open M.O
let rec find_map xs ~f =
match xs with
| [] -> return None
| x :: xs ->
let* x = f x in
(match x with
| None -> find_map xs ~f
| Some s -> return (Some s))
;;
let rec fold_left xs ~f ~init =
match xs with
| [] -> return init
| x :: xs ->
let* init = f init x in
fold_left xs ~f ~init
;;
let filter_map xs ~f =
let rec loop acc = function
| [] -> return (List.rev acc)
| x :: xs ->
let* y = f x in
(match y with
| None -> loop acc xs
| Some y -> loop (y :: acc) xs)
in
loop [] xs
;;
let filter xs ~f =
filter_map xs ~f:(fun x ->
let+ pred = f x in
Option.some_if pred x)
;;
let map xs ~f =
filter_map xs ~f:(fun x ->
let+ x = f x in
Some x)
;;
let concat_map xs ~f = map xs ~f >>| List.concat
let rec iter xs ~f =
match xs with
| [] -> return ()
| x :: xs ->
let* () = f x in
iter xs ~f
;;
let rec for_all xs ~f =
match xs with
| [] -> return true
| x :: xs ->
let* pred = f x in
if pred then for_all xs ~f else return false
;;
let rec exists xs ~f =
match xs with
| [] -> return false
| x :: xs ->
let* pred = f x in
if pred then return true else exists xs ~f
;;
end
module Option (M : S) = struct
let iter option ~f =
match option with
| None -> M.return ()
| Some a -> f a
;;
let map option ~f =
match option with
| None -> M.return None
| Some a -> M.map (f a) ~f:Option.some
;;
let bind option ~f =
match option with
| None -> M.return None
| Some a -> f a
;;
end
module Result (M : S) = struct
let iter result ~f =
match result with
| Error _ -> M.return ()
| Ok a -> f a
;;
end

13
unikernel/duniverse/dune_/otherlibs/stdune/src/monad.mli Normal file
View file

@ -0,0 +1,13 @@
(** Monad signatures *)
module type Basic = Monad_intf.Basic
module type S = Monad_intf.S
module type List = Monad_intf.List
module type Option = Monad_intf.Option
module type Result = Monad_intf.Result
module Make (M : Basic) : S with type 'a t := 'a M.t
module Id : S with type 'a t = 'a
module List (M : S) : List with type 'a t := 'a M.t
module Option (M : S) : Option with type 'a t := 'a M.t
module Result (M : S) : Result with type 'a t := 'a M.t

52
unikernel/duniverse/dune_/otherlibs/stdune/src/monad_intf.ml Normal file
View file

@ -0,0 +1,52 @@
(** This module type is accessible as [Stdune.Monad.Basic] outside of [Stdune]. *)
module type Basic = sig
type 'a t
val return : 'a -> 'a t
val bind : 'a t -> f:('a -> 'b t) -> 'b t
end
(** This module type is accessible as just [Stdune.Monad] outside of [Stdune]. *)
module type S = sig
include Basic
val map : 'a t -> f:('a -> 'b) -> 'b t
module O : sig
val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
val ( >>> ) : unit t -> 'a t -> 'a t
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
val ( and* ) : 'a t -> 'b t -> ('a * 'b) t
end
end
module type List = sig
type 'a t
val find_map : 'a list -> f:('a -> 'b option t) -> 'b option t
val map : 'a list -> f:('a -> 'b t) -> 'b list t
val concat_map : 'a list -> f:('a -> 'b list t) -> 'b list t
val exists : 'a list -> f:('a -> bool t) -> bool t
val iter : 'a list -> f:('a -> unit t) -> unit t
val filter : 'a list -> f:('a -> bool t) -> 'a list t
val filter_map : 'a list -> f:('a -> 'b option t) -> 'b list t
val fold_left : 'a list -> f:('acc -> 'a -> 'acc t) -> init:'acc -> 'acc t
val for_all : 'a list -> f:('a -> bool t) -> bool t
end
module type Option = sig
type 'a t
val iter : 'a option -> f:('a -> unit t) -> unit t
val map : 'a option -> f:('a -> 'b t) -> 'b option t
val bind : 'a option -> f:('a -> 'b option t) -> 'b option t
end
module type Result = sig
type 'a t
val iter : ('a, _) result -> f:('a -> unit t) -> unit t
end

184
unikernel/duniverse/dune_/otherlibs/stdune/src/monoid.ml Normal file
View file

@ -0,0 +1,184 @@
module type Basic = Monoid_intf.Basic
module type S = Monoid_intf.S
module Make (M : Basic) = struct
include M
module O = struct
let ( @ ) = combine
end
let reduce = List.fold_left ~init:empty ~f:combine
let map_reduce ~f = List.fold_left ~init:empty ~f:(fun acc a -> combine acc (f a))
end
module Exists = Make (struct
type t = bool
let empty = false
let combine = ( || )
end)
module Forall = Make (struct
type t = bool
let empty = true
let combine = ( && )
end)
module String = Make (struct
type t = string
let empty = ""
let combine = ( ^ )
end)
module List (M : sig
type t
end) =
Make (struct
type t = M.t list
let empty = []
let combine = ( @ )
end)
module Appendable_list (M : sig
type t
end) =
Make (struct
type t = M.t Appendable_list.t
let empty = Appendable_list.empty
let combine = Appendable_list.( @ )
end)
module Unit = Make (struct
include Unit
let empty = ()
let combine () () = ()
end)
module type Add = sig
type t
val zero : t
val ( + ) : t -> t -> t
end
module Add (M : Add) = Make (struct
include M
let empty = zero
let combine = ( + )
end)
module type Mul = sig
type t
val one : t
val ( * ) : t -> t -> t
end
module Mul (M : Mul) = Make (struct
include M
let empty = one
let combine = ( * )
end)
module type Union = sig
type t
val empty : t
val union : t -> t -> t
end
module Union (M : Union) = Make (struct
include M
let combine = union
end)
module Product (A : Basic) (B : Basic) = Make (struct
type t = A.t * B.t
let empty = A.empty, B.empty
let combine (a1, b1) (a2, b2) = A.combine a1 a2, B.combine b1 b2
end)
module Product3 (A : Basic) (B : Basic) (C : Basic) = Make (struct
type t = A.t * B.t * C.t
let empty = A.empty, B.empty, C.empty
let combine (a1, b1, c1) (a2, b2, c2) =
A.combine a1 a2, B.combine b1 b2, C.combine c1 c2
;;
end)
module Function
(A : sig
type t
end)
(M : Basic) =
Make (struct
type t = A.t -> M.t
let empty _ = M.empty
let combine f g x = M.combine (f x) (g x)
end)
module Endofunction = struct
module Left (A : sig
type t
end) =
Make (struct
type t = A.t -> A.t
let empty x = x
let combine f g x = g (f x)
end)
module Right (A : sig
type t
end) =
Make (struct
type t = A.t -> A.t
let empty x = x
let combine f g x = f (g x)
end)
end
module Commutative = struct
(* Inject the "proof" of commutativity into a give monoid. *)
module Make_commutative (M : S) = struct
include M
type combine_is_commutative = unit
end
module type Basic = Monoid_intf.Commutative.Basic
module type S = Monoid_intf.Commutative.S
module Make (M : Basic) = Make_commutative (Make (M))
module Exists = Make_commutative (Exists)
module Forall = Make_commutative (Forall)
module Unit = Make_commutative (Unit)
module Add (M : Add) = Make_commutative (Add (M))
module Mul (M : Mul) = Make_commutative (Mul (M))
module Union (M : Union) = Make_commutative (Union (M))
module Product (A : Basic) (B : Basic) = Make_commutative (Product (A) (B))
module Product3 (A : Basic) (B : Basic) (C : Basic) =
Make_commutative (Product3 (A) (B) (C))
module Function
(A : sig
type t
end)
(M : Basic) =
Make_commutative (Function (A) (M))
end

155
unikernel/duniverse/dune_/otherlibs/stdune/src/monoid.mli Normal file
View file

@ -0,0 +1,155 @@
(** Monoids and commutative monoids. *)
module type Basic = Monoid_intf.Basic
module type S = Monoid_intf.S
(** This functor extends the basic definition of a monoid by adding a convenient
operator synonym [( @ ) = combine], as well as derived functions [reduce]
and [map_reduce]. *)
module Make (M : Basic) : S with type t := M.t
(** The monoid you get with [empty = false] and [combine = ( || )]. *)
module Exists : S with type t = bool
(** The monoid you get with [empty = true] and [combine = ( && )]. *)
module Forall : S with type t = bool
(** The string concatenation monoid with [empty = ""] and [combine = ( ^ )]. *)
module String : S with type t = string
(** The list monoid with [empty = []] and [combine = ( @ )]. *)
module List (M : sig
type t
end) : S with type t = M.t list
(** The list monoid with [empty = []] and [combine = ( @ )]. *)
module Appendable_list (M : sig
type t
end) : S with type t = M.t Appendable_list.t
(** The trivial monoid with [empty = ()] and [combine () () = ()]. *)
module Unit : S with type t = Unit.t
(** The addition monoid with [empty = zero] and [combine = ( + )]. *)
module Add (M : sig
type t
val zero : t
val ( + ) : t -> t -> t
end) : S with type t = M.t
(** The multiplication monoid with [empty = one] and [combine = ( * )]. *)
module Mul (M : sig
type t
val one : t
val ( * ) : t -> t -> t
end) : S with type t = M.t
(** The union monoid with [empty = M.empty] and [combine = M.union]. *)
module Union (M : sig
type t
val empty : t
val union : t -> t -> t
end) : S with type t = M.t
(** The product of monoids where pairs are combined component-wise. *)
module Product (A : Basic) (B : Basic) : S with type t = A.t * B.t
(** Same as [Product] but for 3 monoids. *)
module Product3 (A : Basic) (B : Basic) (C : Basic) : S with type t = A.t * B.t * C.t
(** Functions that return a monoid form the following monoid:
- empty = fun _ -> M.empty
- combine f g = fun x -> M.combine (f x) (g x) *)
module Function
(A : sig
type t
end)
(M : Basic) : S with type t = A.t -> M.t
(** Endofunctions, i.e., functions of type [t -> t], form two monoids. *)
module Endofunction : sig
(** The left-to-right function composition monoid, where the argument is first
passed to the leftmost function:
- empty = fun x -> x
- combine f g = fun x -> g (f x) *)
module Left (A : sig
type t
end) : S with type t = A.t -> A.t
(** The right-to-left function composition monoid, where the argument is first
passed to the rightmost function:
- empty = fun x -> x
- combine f g = fun x -> f (g x) *)
module Right (A : sig
type t
end) : S with type t = A.t -> A.t
end
(** Commutative monoids. *)
module Commutative : sig
module type Basic = Monoid_intf.Commutative.Basic
module type S = Monoid_intf.Commutative.S
(** This functor extends the basic definition of a commutative monoid by
adding a convenient operator synonym [( @ ) = combine], as well as derived
functions [reduce] and [map_reduce]. *)
module Make (M : Basic) : S with type t := M.t
(** The commutative monoid you get with [empty = false] and
[combine = ( || )]. *)
module Exists : S with type t = bool
(** The commutative monoid you get with [empty = true] and [combine = ( && )]. *)
module Forall : S with type t = bool
(** The trivial commutative monoid with [empty = ()] and [combine () () = ()]. *)
module Unit : S with type t = Unit.t
(** The addition monoid with [empty = zero] and [combine = ( + )]. *)
module Add (M : sig
type t
val zero : t
val ( + ) : t -> t -> t
end) : S with type t = M.t
(** The multiplication monoid with [empty = one] and [combine = ( * )]. *)
module Mul (M : sig
type t
val one : t
val ( * ) : t -> t -> t
end) : S with type t = M.t
(** The union monoid with [empty = M.empty] and [combine = M.union]. *)
module Union (M : sig
type t
val empty : t
val union : t -> t -> t
end) : S with type t = M.t
(** The product of commutative monoids where pairs are combined
component-wise. *)
module Product (A : Basic) (B : Basic) : S with type t = A.t * B.t
(** Same as [Product] but for 3 commutative monoids. *)
module Product3 (A : Basic) (B : Basic) (C : Basic) : S with type t = A.t * B.t * C.t
(** Functions that return a commutative monoid form the following commutative
monoid:
- empty = fun _ -> M.empty
- combine f g = fun x -> M.combine (f x) (g x) *)
module Function
(A : sig
type t
end)
(M : Basic) : S with type t = A.t -> M.t
end

50
unikernel/duniverse/dune_/otherlibs/stdune/src/monoid_intf.ml Normal file
View file

@ -0,0 +1,50 @@
(** A type of values with an associative operation and an identity element, for
example, integers with addition and zero. *)
module type Basic = sig
type t
(** Must be the identity of [combine]:
- combine empty t = t
- combine t empty = t *)
val empty : t
(** Must be associative:
- combine a (combine b c) = combine (combine a b) c *)
val combine : t -> t -> t
end
(** This module type extends the basic definition of a monoid by adding a
convenient operator synonym [( @ ) = combine], as well as derived functions
[reduce] and [map_reduce]. *)
module type S = sig
include Basic
module O : sig
(** An operator alias for [combine]. *)
val ( @ ) : t -> t -> t
end
val reduce : t list -> t
val map_reduce : f:('a -> t) -> 'a list -> t
end
module Commutative = struct
(** Like [Basic] but requires [combine] to be commutative.
The [combine_is_commutative] type is a "proof" of commutativity, so that
one can't simply pass any monoid where a commutative monoid is expected. *)
module type Basic = sig
include Basic
type combine_is_commutative = unit
end
(** Like [S] but requires [combine] to be commutative. *)
module type S = sig
include S
type combine_is_commutative = unit
end
end

11
unikernel/duniverse/dune_/otherlibs/stdune/src/nonempty_list.ml Normal file
View file

@ -0,0 +1,11 @@
type 'a t = ( :: ) of 'a * 'a list
let hd (x :: _) = x
let of_list = function
| [] -> None
| x :: xs -> Some (x :: xs)
;;
let to_list (x :: xs) = List.cons x xs
let map (x :: xs) ~f = f x :: List.map xs ~f

Some files were not shown because too many files have changed in this diff Show more