Source file std.ml

(* {{{ COPYING *(

     This file is part of Merlin, an helper for ocaml editors

     Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
                                Thomas Refis  <refis.thomas(_)gmail.com>
                                Simon Castellan  <simon.castellan(_)iuwt.fr>

     Permission is hereby granted, free of charge, to any person obtaining a
     copy of this software and associated documentation files (the "Software"),
     to deal in the Software without restriction, including without limitation the
     rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
     sell copies of the Software, and to permit persons to whom the Software is
     furnished to do so, subject to the following conditions:

     The above copyright notice and this permission notice shall be included in
     all copies or substantial portions of the Software.

     The Software is provided "as is", without warranty of any kind, express or
     implied, including but not limited to the warranties of merchantability,
     fitness for a particular purpose and noninfringement. In no event shall
     the authors or copyright holders be liable for any claim, damages or other
     liability, whether in an action of contract, tort or otherwise, arising
     from, out of or in connection with the software or the use or other dealings
     in the Software.

   )* }}} *)

type json =
  [ `Assoc of (string * json) list
  | `Bool of bool
  | `Float of float
  | `Int of int
  | `List of json list
  | `Null
  | `String of string ]

module Json = struct
  type t = json

  let string x = `String x
  let int x = `Int x
  let bool x = `Bool x

  let option f = function
    | None -> `Null
    | Some x -> f x

  let list f x = `List (List.map f x)

  let pretty_to_string : (t -> string) ref =
    ref @@ fun _ ->
    Printf.sprintf
      "Logger error: `Std.Json.pretty_to_string` is not set. You should \
       initialize that reference with the pretifier of your choice to enable \
       json logging. A common one is `Yojson.Basic.pretty_to_string`."
end

module Hashtbl = struct
  include Hashtbl

  let find_some tbl key = try Some (find tbl key) with Not_found -> None

  let elements tbl = Hashtbl.fold (fun _key elt acc -> elt :: acc) tbl []

  let forall table f =
    match Hashtbl.iter (fun k v -> if not (f k v) then raise Exit) table with
    | () -> true
    | exception Exit -> false
end

module List = struct
  include ListLabels

  let init ~f n =
    let rec aux i = if i = n then [] else f i :: aux (succ i) in
    aux 0

  let index ~f l =
    let rec aux i = function
      | [] -> raise Not_found
      | x :: _ when f x -> i
      | _ :: xs -> aux (succ i) xs
    in
    aux 0 l

  let find_some ~f l = try Some (find ~f l) with Not_found -> None

  let rec rev_scan_left acc ~f l ~init =
    match l with
    | [] -> acc
    | x :: xs ->
      let init = f init x in
      rev_scan_left (init :: acc) ~f xs ~init

  let scan_left ~f l ~init = List.rev (rev_scan_left [] ~f l ~init)

  let rev_filter ~f lst =
    let rec aux acc = function
      | [] -> acc
      | x :: xs -> aux (if f x then x :: acc else acc) xs
    in
    aux [] lst

  let rec filter_map ~f = function
    | [] -> []
    | x :: xs -> (
      match f x with
      | None -> filter_map ~f xs
      | Some x -> x :: filter_map ~f xs)

  let rec find_map ~f = function
    | [] -> raise Not_found
    | x :: xs -> (
      match f x with
      | None -> find_map ~f xs
      | Some x' -> x')

  let rec map_end ~f l1 l2 =
    match l1 with
    | [] -> l2
    | hd :: tl -> f hd :: map_end ~f tl l2

  let concat_map ~f l = flatten (map ~f l)

  let replicate elem n =
    let rec aux acc elem n =
      if n <= 0 then acc else aux (elem :: acc) elem (n - 1)
    in
    aux [] elem n

  let rec remove ?(phys = false) x =
    let check = if phys then ( == ) else ( = ) in
    function
    | [] -> []
    | hd :: tl when check x hd -> tl
    | hd :: tl -> hd :: remove ~phys x tl

  let rec remove_all x = function
    | [] -> []
    | hd :: tl when x = hd -> remove_all x tl
    | hd :: tl -> hd :: remove_all x tl

  let rec same ~f l1 l2 =
    match (l1, l2) with
    | [], [] -> true
    | hd1 :: tl1, hd2 :: tl2 when f hd1 hd2 -> same ~f tl1 tl2
    | _, _ -> false

  (* [length_lessthan n l] returns
   *   Some (List.length l) if List.length l <= n
   *   None otherwise *)
  let length_lessthan n l =
    let rec aux i = function
      | _ :: xs when i < n -> aux (succ i) xs
      | [] -> Some i
      | _ -> None
    in
    aux 0 l

  let filter_dup' ~equiv lst =
    let tbl = Hashtbl.create 17 in
    let f a b =
      let b' = equiv b in
      if Hashtbl.mem tbl b' then a
      else (
        Hashtbl.add tbl b' ();
        b :: a)
    in
    rev (fold_left ~f ~init:[] lst)

  let filter_dup lst = filter_dup' ~equiv:(fun x -> x) lst

  let rec merge_cons ~f = function
    | a :: (b :: tl as tl') -> begin
      match f a b with
      | Some a' -> merge_cons ~f (a' :: tl)
      | None -> a :: merge_cons ~f tl'
    end
    | tl -> tl

  let rec take_while ~f = function
    | x :: xs when f x -> x :: take_while ~f xs
    | _ -> []

  let rec drop_while ~f = function
    | x :: xs when f x -> drop_while ~f xs
    | xs -> xs

  let rec take_n acc n = function
    | x :: xs when n > 0 -> take_n (x :: acc) (n - 1) xs
    | _ -> List.rev acc
  let take_n n l = take_n [] n l

  let rec drop_n n = function
    | _ :: xs when n > 0 -> drop_n (n - 1) xs
    | xs -> xs

  let rec split_n acc n = function
    | x :: xs when n > 0 -> split_n (x :: acc) (n - 1) xs
    | xs -> (List.rev acc, xs)
  let split_n n l = split_n [] n l

  let rec split3 xs ys zs = function
    | (x, y, z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl
    | [] -> (List.rev xs, List.rev ys, List.rev zs)
  let split3 l = split3 [] [] [] l

  let rec unfold ~f a =
    match f a with
    | None -> []
    | Some a -> a :: unfold ~f a

  let rec rev_unfold acc ~f a =
    match f a with
    | None -> acc
    | Some a -> rev_unfold (a :: acc) ~f a

  let rec fold_n_map ~f ~init = function
    | [] -> (init, [])
    | x :: xs ->
      let acc, x' = f init x in
      let acc, xs' = fold_n_map ~f ~init:acc xs in
      (acc, x' :: xs')

  let rec iteri2 i ~f l1 l2 =
    match (l1, l2) with
    | [], [] -> ()
    | a1 :: l1, a2 :: l2 ->
      f i a1 a2;
      iteri2 (i + 1) ~f l1 l2
    | _, _ -> raise (Invalid_argument "iteri2")

  let iteri2 ~f l1 l2 = iteri2 0 ~f l1 l2

  module Lazy = struct
    type 'a t = Nil | Cons of 'a * 'a t lazy_t

    let rec map ~f = function
      | Nil -> Nil
      | Cons (hd, tl) -> Cons (f hd, lazy (map ~f (Lazy.force tl)))

    let rec to_strict = function
      | Nil -> []
      | Cons (hd, (lazy tl)) -> hd :: to_strict tl

    let rec unfold f a =
      match f a with
      | None -> Nil
      | Some a -> Cons (a, lazy (unfold f a))

    let rec filter_map ~f = function
      | Nil -> Nil
      | Cons (a, tl) -> (
        match f a with
        | None -> filter_map ~f (Lazy.force tl)
        | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl))))
  end

  let hd_opt = function
    | [] -> None
    | x :: _ -> Some x

  let rec last = function
    | [] -> None
    | [ x ] -> Some x
    | _ :: l -> last l

  let rec group_by pred group acc = function
    | [] -> List.rev acc
    | x :: xs -> (
      match group with
      | x' :: _ when pred x x' -> group_by pred (x :: group) acc xs
      | _ -> group_by pred [ x ] (group :: acc) xs)

  let group_by pred xs =
    match group_by pred [] [] xs with
    | [] :: xs | xs -> xs

  (* Merge sorted lists *)
  let rec merge ~cmp l1 l2 =
    match (l1, l2) with
    | l, [] | [], l -> l
    | x1 :: _, x2 :: x2s when cmp x1 x2 > 0 -> x2 :: merge ~cmp l1 x2s
    | x1 :: x1s, _ -> x1 :: merge ~cmp x1s l2

  let rec dedup_adjacent ~cmp = function
    | x1 :: (x2 :: _ as xs) when cmp x1 x2 = 0 -> dedup_adjacent ~cmp xs
    | x :: xs -> x :: dedup_adjacent ~cmp xs
    | [] -> []

  (* [sort_uniq] does not need to maintain a set of seen entries because duplicates will
     be adjacent. *)
  let sort_uniq ~cmp l = dedup_adjacent ~cmp (sort ~cmp l)

  let print f () l = "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]"

  let max_elt list ~cmp =
    fold_left list ~init:None ~f:(fun acc elt ->
        match acc with
        | None -> Some elt
        | Some max -> if cmp max elt < 0 then Some elt else acc)

  let min_elt list ~cmp =
    fold_left list ~init:None ~f:(fun acc elt ->
        match acc with
        | None -> Some elt
        | Some min -> if cmp min elt > 0 then Some elt else acc)
end

module Option = struct
  let bind opt ~f =
    match opt with
    | None -> None
    | Some x -> f x

  let map ~f = function
    | None -> None
    | Some x -> Some (f x)

  let get = function
    | None -> raise Not_found
    | Some x -> x

  let value ~default = function
    | None -> default
    | Some x -> x

  let value_map ~f ~default = function
    | None -> default
    | Some x -> f x

  let iter ~f = function
    | None -> ()
    | Some x -> f x

  let cons o xs =
    match o with
    | None -> xs
    | Some x -> x :: xs

  module Infix = struct
    let return x = Some x
    let ( >>= ) x f = bind x ~f
    let ( >>| ) x f = map x ~f
    let ( let* ) opt f = bind opt ~f
    let ( let+ ) opt f = map opt ~f
  end

  include Infix

  let to_list = function
    | None -> []
    | Some x -> [ x ]

  let is_some = function
    | None -> false
    | _ -> true

  let plus a b =
    match a with
    | Some _ -> a
    | None -> b

  let print f () = function
    | None -> "None"
    | Some s -> "Some (" ^ f () s ^ ")"
end

module Result = struct
  include Result

  let map ~f r = Result.map f r
  let bind ~f r = Result.bind r f
end

module String = struct
  include StringLabels

  let for_all f t =
    let len = String.length t in
    let rec loop i = i = len || (f t.[i] && loop (i + 1)) in
    loop 0

  let reverse s1 =
    let len = length s1 in
    let s2 = Bytes.make len 'a' in
    for i = 0 to len - 1 do
      Bytes.set s2 i s1.[len - i - 1]
    done;
    Bytes.to_string s2

  let common_prefix_len s1 s2 =
    let rec aux i =
      if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i
      else aux (succ i)
    in
    aux 0

  (* [is_prefixed ~by s] returns [true] iff [by] is a prefix of [s] *)
  let is_prefixed ~by =
    let l = String.length by in
    fun s ->
      let l' = String.length s in
      l' >= l
      &&
      try
        for i = 0 to pred l do
          if s.[i] <> by.[i] then raise Not_found
        done;
        true
      with Not_found -> false

  (* Drop characters from beginning of string *)
  let drop n s = sub s ~pos:n ~len:(length s - n)

  module Set = struct
    include MoreLabels.Set.Make (struct
      type t = string
      let compare = compare
    end)
    let of_list l = List.fold_left ~f:(fun s elt -> add elt s) l ~init:empty
    let to_list s = fold ~f:(fun x xs -> x :: xs) s ~init:[]
  end

  module Map = struct
    include MoreLabels.Map.Make (struct
      type t = string
      let compare = compare
    end)
    let of_list l =
      List.fold_left ~f:(fun m (k, v) -> add ~key:k ~data:v m) l ~init:empty
    let to_list m = fold ~f:(fun ~key ~data xs -> (key, data) :: xs) m ~init:[]

    let keys m = fold ~f:(fun ~key ~data:_ xs -> key :: xs) m ~init:[]
    let values m = fold ~f:(fun ~key:_ ~data xs -> data :: xs) m ~init:[]

    let add_multiple key data t =
      let current = try find key t with Not_found -> [] in
      let data = data :: current in
      add ~key ~data t
  end

  let mem c s =
    try
      ignore (String.index s c : int);
      true
    with Not_found -> false

  let first_double_underscore_end s =
    let len = String.length s in
    let rec aux i =
      if i > len - 2 then raise Not_found
      else if s.[i] = '_' && s.[i + 1] = '_' then i + 1
      else aux (i + 1)
    in
    aux 0

  let no_double_underscore s =
    try
      ignore (first_double_underscore_end s);
      false
    with Not_found -> true

  let trim = function
    | "" -> ""
    | str ->
      let l = String.length str in
      let is_space = function
        | ' ' | '\n' | '\t' | '\r' -> true
        | _ -> false
      in
      let r0 = ref 0 and rl = ref l in
      while !r0 < l && is_space str.[!r0] do
        incr r0
      done;
      let r0 = !r0 in
      while !rl > r0 && is_space str.[!rl - 1] do
        decr rl
      done;
      let rl = !rl in
      if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0)

  let print () s = Printf.sprintf "%S" s

  let capitalize = capitalize_ascii
  let uncapitalize = uncapitalize_ascii

  let lowercase = lowercase_ascii
  let uppercase = uppercase_ascii

  let split_on_char_ c s =
    match String.index s c with
    | exception Not_found -> [ s ]
    | p ->
      let rec loop i =
        match String.index_from s i c with
        | exception Not_found -> [ String.sub s i (String.length s - i) ]
        | j ->
          let s0 = String.sub s i (j - i) in
          s0 :: loop (j + 1)
      in
      let s0 = String.sub s 0 p in
      s0 :: loop (p + 1)

  let chop_prefix ~prefix text =
    let tlen = String.length text in
    let plen = String.length prefix in
    if tlen >= plen then
      try
        for i = 0 to plen - 1 do
          if prefix.[i] <> text.[i] then raise Not_found
        done;
        Some (String.sub text plen (tlen - plen))
      with Not_found -> None
    else None

  let next_occurrence ~pattern text from =
    let plen = String.length pattern in
    let last = String.length text - plen in
    let i = ref from and j = ref 0 in
    while !i <= last && !j < plen do
      if text.[!i + !j] <> pattern.[!j] then (
        incr i;
        j := 0)
      else incr j
    done;
    if !j < plen then raise Not_found else !i

  let replace_all ~pattern ~with_ text =
    if pattern = "" then text
    else
      match next_occurrence ~pattern text 0 with
      | exception Not_found -> text
      | j0 ->
        let buffer = Buffer.create (String.length text) in
        let rec aux i j =
          Buffer.add_substring buffer text i (j - i);
          Buffer.add_string buffer with_;
          let i' = j + String.length pattern in
          match next_occurrence ~pattern text i' with
          | exception Not_found ->
            Buffer.add_substring buffer text i' (String.length text - i')
          | j' -> aux i' j'
        in
        aux 0 j0;
        Buffer.contents buffer

  let rfindi =
    let rec loop s ~f i =
      if i < 0 then None
      else if f (String.unsafe_get s i) then Some i
      else loop s ~f (i - 1)
    in
    fun ?from s ~f ->
      let from =
        let len = String.length s in
        match from with
        | None -> len - 1
        | Some i -> if i > len - 1 then failwith "rfindi: invalid from" else i
      in
      loop s ~f from

  let rec check_prefix s ~prefix len i =
    i = len || (s.[i] = prefix.[i] && check_prefix s ~prefix len (i + 1))

  let lsplit2 s ~on =
    match String.index_opt s on with
    | None -> None
    | Some i ->
      Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))

  let is_prefix s ~prefix =
    let len = length s in
    let prefix_len = length prefix in
    len >= prefix_len && check_prefix s ~prefix prefix_len 0
end

let sprintf = Printf.sprintf

module Format = struct
  include Format

  let default_width = ref 0

  let to_string ?(width = !default_width) () =
    let b = Buffer.create 32 in
    let ppf = formatter_of_buffer b in
    let contents () =
      pp_print_flush ppf ();
      Buffer.contents b
    in
    pp_set_margin ppf width;
    (ppf, contents)
end

module Lexing = struct
  type position = Lexing.position =
    { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int }

  include (
    Lexing :
      module type of struct
        include Lexing
      end
      with type position := position)

  let move buf p =
    buf.lex_abs_pos <- p.pos_cnum - buf.lex_curr_pos;
    buf.lex_curr_p <- p

  let from_strings ?empty ?position source refill =
    let pos = ref 0 in
    let len = ref (String.length source) in
    let source = ref source in
    let lex_fun buf size =
      let count = min (!len - !pos) size in
      let count =
        if count <= 0 then begin
          source := refill ();
          len := String.length !source;
          pos := 0;
          min !len size
        end
        else count
      in
      if count <= 0 then 0
      else begin
        String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count;
        pos := !pos + count;
        (match empty with
        | None -> ()
        | Some r -> r := !pos >= !len);
        count
      end
    in
    let buf = from_function lex_fun in
    Option.iter ~f:(move buf) position;
    buf

  (* Manipulating position *)
  let make_pos ?(pos_fname = "") (pos_lnum, pos_cnum) =
    { pos_fname; pos_lnum; pos_cnum; pos_bol = 0 }

  let column pos = pos.pos_cnum - pos.pos_bol

  let set_column pos col = { pos with pos_cnum = pos.pos_bol + col }

  let split_pos pos = (pos.pos_lnum, column pos)

  let compare_pos p1 p2 =
    match compare p1.pos_lnum p2.pos_lnum with
    | 0 -> compare (column p1) (column p2)
    | n -> n

  let print_position () p =
    let l1, c1 = split_pos p in
    sprintf "%d:%d" l1 c1

  (* Current position in lexer, even if the buffer is in the middle of a refill
     operation *)
  let immediate_pos buf =
    { buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos }

  let json_of_position pos =
    let line, col = split_pos pos in
    `Assoc [ ("line", `Int line); ("col", `Int col) ]

  let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2

  let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2
end

module Char = struct
  (* FIXME: Remove once we drop support for 4.02 and replace the calls to
     [uppercase] and [lowercase] by their [_ascii] version. *)
  [@@@ocaml.warning "-3"]

  include Char
  let is_lowercase c = lowercase_ascii c = c
  let is_uppercase c = uppercase_ascii c = c
  let is_strictly_lowercase c = not (is_uppercase c)
  let is_strictly_uppercase c = not (is_lowercase c)
end

module Glob : sig
  type pattern = Wildwild | Exact of string | Regexp of Str.regexp
  val compile_pattern : string -> pattern
  val match_pattern : pattern -> string -> bool
end = struct
  type pattern = Wildwild | Exact of string | Regexp of Str.regexp

  let compile_pattern = function
    | "**" -> Wildwild
    | pattern ->
      let regexp = Buffer.create 15 in
      let chunk = Buffer.create 15 in
      let flush () =
        if Buffer.length chunk > 0 then (
          Buffer.add_string regexp (Str.quote (Buffer.contents chunk));
          Buffer.clear chunk)
      in
      let l = String.length pattern in
      let i = ref 0 in
      while !i < l do
        begin
          match pattern.[!i] with
          | '\\' ->
            incr i;
            if !i < l then Buffer.add_char chunk pattern.[!i]
          | '*' ->
            flush ();
            Buffer.add_string regexp ".*"
          | '?' ->
            flush ();
            Buffer.add_char regexp '.'
          | x -> Buffer.add_char chunk x
        end;
        incr i
      done;
      if Buffer.length regexp = 0 then Exact (Buffer.contents chunk)
      else (
        flush ();
        Buffer.add_char regexp '$';
        Regexp (Str.regexp (Buffer.contents regexp)))

  let match_pattern re str =
    match re with
    | Wildwild -> true
    | Regexp re -> Str.string_match re str 0
    | Exact s -> s = str
end

let fprintf = Format.fprintf

let lazy_eq a b =
  match (Lazy.is_val a, Lazy.is_val b) with
  | true, true -> Lazy.force_val a == Lazy.force_val b
  | false, false -> a == b
  | _ -> false

let let_ref r v f =
  let v' = !r in
  r := v;
  match f () with
  | result ->
    r := v';
    result
  | exception exn ->
    r := v';
    raise exn

let failwithf fmt = Printf.ksprintf failwith fmt

module Shell = struct
  let split_command str =
    let comps = ref [] in
    let dirty = ref false in
    let buf = Buffer.create 16 in
    let flush () =
      if !dirty then (
        comps := Buffer.contents buf :: !comps;
        dirty := false;
        Buffer.clear buf)
    in
    let i = ref 0 and len = String.length str in
    let unescape = function
      | 'n' -> '\n'
      | 'r' -> '\r'
      | 't' -> '\t'
      | x -> x
    in
    while !i < len do
      let c = str.[!i] in
      incr i;
      match c with
      | ' ' | '\t' | '\n' | '\r' -> flush ()
      | '\\' ->
        dirty := true;
        if !i < len then (
          Buffer.add_char buf (unescape str.[!i]);
          incr i)
      | '\'' ->
        dirty := true;
        while !i < len && str.[!i] <> '\'' do
          Buffer.add_char buf str.[!i];
          incr i
        done;
        incr i
      | '"' ->
        dirty := true;
        while !i < len && str.[!i] <> '"' do
          (match str.[!i] with
          | '\\' ->
            incr i;
            if !i < len then Buffer.add_char buf (unescape str.[!i])
          | x -> Buffer.add_char buf x);
          incr i
        done;
        incr i
      | x ->
        dirty := true;
        Buffer.add_char buf x
    done;
    flush ();
    List.rev !comps
end

module System = struct
  external windows_merlin_system_command :
    string -> cwd:string -> ?outfile:string -> int = "ml_merlin_system_command"

  let run_in_directory :
      (prog:string ->
      prog_is_quoted:bool ->
      args:string list ->
      cwd:string ->
      ?stdin:string ->
      ?stdout:string ->
      ?stderr:string ->
      unit ->
      [ `Finished of int | `Cancelled ])
      ref =
    ref
    @@ fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () ->
    (* Currently we assume that [prog] is always quoted and might contain
       arguments such as [-as-ppx]. This is due to the way Merlin gets its
       configuration. Thus we cannot rely on [Filename.quote_command]. *)
    let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in
    (* Runned program should never output on stdout since it is the
        channel used by Merlin to communicate with the editor *)
    let args =
      if Sys.win32 then args
      else
        let stdout =
          match stdout with
          | Some file -> Filename.quote file
          | None -> "&2"
        in
        Printf.sprintf "%s 1>%s" args stdout
    in
    let cmd = Format.sprintf "%s %s" prog args in
    let exit_code =
      if Sys.win32 then
        (* Note: the following function will never output to stdout.
           When [stdout = None], stdout is sent to stderr. *)
        windows_merlin_system_command cmd ~cwd ?outfile:stdout
      else Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd)
    in
    `Finished exit_code
end

(* [modules_in_path ~ext path] lists ocaml modules corresponding to
 * filenames with extension [ext] in given [path]es.
 * For instance, if there is file "a.ml","a.mli","b.ml" in ".":
 * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"],
 * - modules_in_path ~ext:".mli" ["."] returns ["A"] *)
let modules_in_path ~ext path =
  let seen = Hashtbl.create 7 in
  List.fold_left ~init:[] path
    ~f:
      begin
        fun results dir ->
          try
            Array.fold_left
              begin
                fun results file ->
                  if Filename.check_suffix file ext then
                    let name = Filename.chop_extension file in
                    if Hashtbl.mem seen name then results
                    else (
                      Hashtbl.add seen name ();
                      String.capitalize name :: results)
                  else results
              end
              results (Sys.readdir dir)
          with Sys_error _ -> results
      end

let file_contents filename =
  let ic = open_in filename in
  try
    let str = Bytes.create 1024 in
    let buf = Buffer.create 1024 in
    let rec loop () =
      match input ic str 0 1024 with
      | 0 -> ()
      | n ->
        Buffer.add_subbytes buf str 0 n;
        loop ()
    in
    loop ();
    close_in_noerr ic;
    Buffer.contents buf
  with exn ->
    close_in_noerr ic;
    raise exn

external reraise : exn -> 'a = "%reraise"

(** Some value that must be interpreted with respect to a specific work
    directory. (e.g. for resolving relative paths or executing sub-commands *)
type 'a with_workdir = { workdir : string; workval : 'a }

let dump_with_workdir f x : json =
  `Assoc [ ("workdir", `String x.workdir); ("workval", f x.workval) ]