Source file omod_support.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2018 The omod programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open Omod.Private

let () = (* Redo that here we don't have Unix in Omod *)
  Fmt.ansi_tty := begin
    let rec isatty fd = try Unix.isatty fd with
    | Unix.Unix_error (Unix.EINTR, _, _) -> isatty fd
    | Unix.Unix_error (e, _, _) -> false
    in
    if not (isatty Unix.stdout) then false else
    match Sys.getenv "TERM" with
    | exception Not_found -> false
    | "" | "dumb" -> false
    | _ -> true
  end

let strf = Format.asprintf

module Codec = struct
  type 'a t = { id : string }
  let v ~id = { id }
  let magic = Printf.sprintf "omod-v0.0.4-ocaml-%s-" Sys.ocaml_version
  let magic c = magic ^ c.id
  let write : type a. a t -> Omod.fpath -> a -> (unit, string) result =
    fun c f v ->
      File.with_open_out f @@ fun oc ->
      output_string oc (magic c);
      output_value oc v;
      flush oc

  let read : type a. a t -> Omod.fpath -> (a, string) result =
    fun c f ->
      try
        File.with_open_in f @@ fun ic ->
        let magic = magic c in
        let m = really_input_string ic (String.length magic) in
        match m = magic with
        | true -> (input_value ic : a)
        | false ->
            failwith (strf "%s: invalid magic number %S, expected %S" f m magic)
      with
      | Failure e -> Error e
end

module Digest = struct
  include Digest
  let pp ppf d = Format.pp_print_string ppf (to_hex d)
  let pp_opt ppf = function
  | None -> Fmt.string ppf "--------------------------------"
  | Some d -> pp ppf d
  module Set = Set.Make (Digest)
  module Map = Map.Make (Digest)
end

module Log = struct
  type t = { f : 'a. ('a, Format.formatter, unit) Stdlib.format -> 'a }
  let exe = Filename.basename Sys.executable_name
  let nil = let f fmt = Format.ifprintf Format.std_formatter fmt in { f }
  let std = let f fmt = Format.printf ("%s: " ^^ fmt ^^ "@.") exe in { f }
  let err = let f fmt = Format.eprintf ("%s: " ^^ fmt ^^ "@.") exe in { f }
  let time l label f =
    let start = Sys.time () in
    let r = f () in
    l.f "%s: %g" label (Sys.time () -. start);
    r
end

module Dir = struct
  let rec exists dir =
    try Ok (Unix.((stat dir).st_kind = S_DIR)) with
    | Unix.Unix_error (Unix.ENOENT, _, _) -> Ok false
    | Unix.Unix_error (Unix.EINTR, _, _) -> exists dir
    | Unix.Unix_error (e, _, _) ->
        Error (strf "directory %s exists: %s" dir (Unix.error_message e))

  let create ?(path = true) ?(mode = 0o755) dir =
    let rec mkdir d mode = try Ok (Unix.mkdir d mode) with
    | Unix.Unix_error (Unix.EEXIST, _, _) -> Ok ()
    | Unix.Unix_error (e, _, _) ->
        let err = Unix.error_message e in
        if d = dir
        then Error (strf "create directory %s: %s" d err)
        else Error (strf "create directory %s: %s: %s" dir d err)
    in
    let rec create_them dirs = match dirs with
    | [] -> Ok true
    | dir :: dirs ->
        match mkdir dir mode with Error _ as e -> e | Ok () -> create_them dirs
    in
    let rec dirs_to_create p acc = match exists p with
    | Error _ as e -> e
    | Ok true -> Ok acc
    | Ok false -> dirs_to_create (Filename.dirname p) (p :: acc)
    in
    match exists dir with
    | Error _ as e -> e
    | Ok true -> Ok false
    | Ok false ->
        match path with
        | false -> create_them [dir]
        | true ->
            match dirs_to_create dir [] with
            | Error _ as e -> e
            | Ok dirs -> create_them dirs
end

module Cobj = struct
  type pkg_id = string * Omod.fpath
  let pp_pkg_id ppf (id, loc) = Fmt.pf ppf "%s %a" id Fmt.faint loc
  let pkg_compare = Stdlib.compare

  type dep = string * Digest.t option
  let pp_dep ppf (n, d) = Fmt.pf ppf "%a %s" Digest.pp_opt d n

  let spec_of_string s =
    try
      let toplevel_module s =
        match String.index s '.' with
        | exception Not_found -> String.capitalize_ascii s
        | i -> failwith (strf "'%s' is not a toplevel module identifier." s)
      in
      let cut_variants pkg s = match String.cut ~sep:'@' s with
      | None -> pkg, toplevel_module s, []
      | Some (m, vs) -> pkg, toplevel_module m, String.rev_cuts ~sep:'@' vs
      in
      match String.cut ~sep:'.' s with
      | None -> Ok (cut_variants None s)
      | Some (pkg, s) -> Ok (cut_variants (Some pkg) s)
    with
    | Failure msg -> Error msg

  type kind = Cmi | Cmo | Cmx
  let kind_to_string = function Cmi -> "cmi" | Cmo -> "cmo" | Cmx -> "cmx"
  let kind_of_string = function
  | "cmi" -> Some Cmi | "cmo" -> Some Cmo | "cmx" -> Some Cmx | _ -> None

  let exts = (* Defines what gets indexed *)
    String.Set.of_list ["cmi"; "cmo"; "cma"; "cmx"; "cmxa"; ]

  type t =
    { kind : kind; pkg_id : pkg_id; name : string; variant : string;
      iface_digest : Digest.t option; iface_deps : dep list;
      in_archive : bool; path : Omod.fpath; path_loads : t list Lazy.t; }

  let variant_of_path (_, pkg_path) path =
    String.map (function '\\' -> '/' | c -> c) (* normalize on windows *) @@
    if not (String.starts_with ~prefix:pkg_path path) then "" else
    let chop p s =
      let first = match p.[String.length p - 1] with
      | '/' | '\\' -> String.length p | _ -> String.length p + 1
      in
      String.(sub s first (length s - first))
    in
    let variant = chop pkg_path path in
    let variant = Filename.dirname variant in
    if variant = "." || variant = "" then "" else
    if variant.[0] = '@'
    then String.sub variant 1 (String.length variant - 1)
    else variant

  let modname_of_path path =
    String.capitalize_ascii @@ fst @@ File.cut_ext @@ Filename.basename path

  let v
      ~kind ~pkg_id ~name ~iface_digest ~iface_deps ~in_archive ~path
      ~path_loads
    =
    let variant = variant_of_path pkg_id path in
    { kind; pkg_id; name; variant; iface_digest; iface_deps; in_archive; path;
      path_loads }

  let kind c = c.kind
  let name c = c.name
  let variant c = c.variant
  let pkg_id c = c.pkg_id
  let iface_digest c = c.iface_digest
  let iface_deps c = c.iface_deps
  let in_archive c = c.in_archive
  let path c = c.path
  let path_loads c = Lazy.force c.path_loads
  let to_dep c = c.name, c.iface_digest
  let is_kind k c = c.kind = k
  let equal c c' = c = c'
  let compare = Stdlib.compare
  let ui_compare o0 o1 =
    let c = String.compare (name o0) (name o1) in
    if c <> 0 then c else
    let c = pkg_compare (pkg_id o0) (pkg_id o1) in
    if c <> 0 then c else
    let c = String.compare (variant o0) (variant o1) in
    if c <> 0 then c else
    String.compare (path o0) (path o1)

  let pp ppf c =
    Fmt.pf ppf "@[<v>%s%s %a@,| kind: %s@,| pkg: %a \
                @,| iface-digest: %a@,| iface-deps: @[<v>%a@]\
                @,| path-loads: @[<v>%a@]@]"
      (name c)
      (if (variant c) <> "" then "@" ^ (variant c) else "")
      Fmt.faint (path c) (kind_to_string @@ kind c)
      pp_pkg_id (pkg_id c) Digest.pp_opt (iface_digest c)
      (Fmt.list pp_dep) (iface_deps c)
      (Fmt.list pp_dep) (List.map to_dep @@ path_loads c)

  let of_dobj (module O : Omod_ocamlc.DOBJ) kind ~pkg_id acc path =
    match O.read path with
    | Error _ as e -> e
    | Ok obj ->
        let name = O.name obj in
        let variant = variant_of_path pkg_id path in
        let iface_digest = Some (O.iface_digest obj) in
        let iface_deps = O.iface_deps obj in
        let rec cobj =
          { kind; name; pkg_id; variant; iface_digest; iface_deps;
            in_archive = false; path; path_loads = lazy [cobj] }
        in
        ignore (path_loads cobj) (* Force lazy for marshaling *);
        Ok (cobj :: acc)

  let of_cma ~pkg_id acc path = match Omod_ocamlc.Cma.read path with
  | Error _ as e -> e
  | Ok cma ->
      let cmos = Omod_ocamlc.Cma.cmos cma in
      let cobj_of_cmo ~pkg_id path path_loads cmo =
        let rec cobj =
          { kind = Cmo; name = Omod_ocamlc.Cmo.name cmo; pkg_id;
            variant = variant_of_path pkg_id path;
            iface_digest = Some (Omod_ocamlc.Cmo.iface_digest cmo);
            iface_deps = Omod_ocamlc.Cmo.iface_deps cmo; path;
            in_archive = true;
            path_loads; }
        in
        cobj
      in
      let rec path_loads =
        lazy (List.map (cobj_of_cmo ~pkg_id path path_loads) cmos)
      in
      let cmos = Lazy.force path_loads in
      Ok (List.fold_left (fun acc cmo -> cmo :: acc) acc cmos)

  let of_cmxa ~pkg_id acc path = match Omod_ocamlc.Cmxa.read path with
  | Error _ as e -> e
  | Ok cmxa ->
      let cmxs = Omod_ocamlc.Cmxa.cmxs cmxa in
      let cobj_of_cmx ~pkg_id path path_loads cmx =
        let rec cobj =
          { kind = Cmx; name = Omod_ocamlc.Cmx.name cmx; pkg_id;
            variant = variant_of_path pkg_id path;
            iface_digest = Some (Omod_ocamlc.Cmx.iface_digest cmx);
            iface_deps = Omod_ocamlc.Cmx.iface_deps cmx; path;
            in_archive = true;
            path_loads; }
        in
        cobj
      in
      let rec path_loads =
        lazy (List.map (cobj_of_cmx ~pkg_id path path_loads) cmxs)
      in
      let cmxs = Lazy.force path_loads in
      Ok (List.fold_left (fun acc cmx -> cmx :: acc) acc cmxs)

  let add_file ~pkg_id acc file =
    let ext = snd @@ File.cut_ext file in
    if not (String.Set.mem ext exts) then Ok acc else match ext with
    | "cmi" -> of_dobj (module Omod_ocamlc.Cmi) Cmi ~pkg_id acc file
    | "cmo" -> of_dobj (module Omod_ocamlc.Cmo) Cmo ~pkg_id acc file
    | "cma" -> of_cma ~pkg_id acc file
    | "cmx" -> of_dobj (module Omod_ocamlc.Cmx) Cmx ~pkg_id acc file
    | "cmxa" -> of_cmxa ~pkg_id acc file
    | _ -> assert false

  (* Indexes and dependency resolvers *)

  module Index = struct
    type cobj = t
    type t =
      { nmap : cobj list String.Map.t; dmap : cobj list Digest.Map.t;
        pmap : cobj list String.Map.t; }

    let empty =
      { nmap = String.Map.empty; dmap = Digest.Map.empty;
        pmap = String.Map.empty }

    let of_cobjs ?(init = empty) cobjs =
      let add_name k v m = match String.Map.find k m with
      | exception Not_found -> String.Map.add k [v] m
      | vs -> String.Map.add k (v :: vs) m
      in
      let add_digest k v m = match Digest.Map.find k m with
      | exception Not_found -> Digest.Map.add k [v] m
      | vs -> Digest.Map.add k (v :: vs) m
      in
      let rec loop nmap dmap pmap = function
      | [] -> { nmap; dmap; pmap }
      | c :: cs ->
          let nmap = add_name (name c) c nmap in
          let dmap = match iface_digest c with
          | None -> dmap
          | Some d -> add_digest d c dmap
          in
          let pmap = add_name (fst (pkg_id c)) c pmap in
          loop nmap dmap pmap cs
      in
      loop init.nmap init.dmap init.pmap cobjs

    let cobjs i =
      let add_pkg _ cobjs acc = List.rev_append cobjs acc in
      String.Map.fold add_pkg i.pmap []

    let cobjs_by_name i = i.nmap
    let cobjs_by_digest i = i.dmap
    let cobjs_by_pkg_name i = i.pmap

    let cobjs_for_mod_name n i = match String.Map.find n i.nmap with
    | exception Not_found -> [] | cobjs -> cobjs

    let cobjs_for_iface_digest d i = match Digest.Map.find d i.dmap with
    | exception Not_found -> [] | cobjs -> cobjs

    let cobjs_for_pkg_name n i = match String.Map.find n i.pmap with
    | exception Not_found -> [] | cobjs -> cobjs

    let cobjs_for_dep (n, d) i = match d with
    | None -> cobjs_for_mod_name n i
    | Some d -> cobjs_for_iface_digest d i

    let cobjs_for_dep_res ~variants ~sat ~kind dep i =
      let sat_obj o = is_kind kind o && sat o in
      let try_select_variants = function
      | ([] | [_]) as l -> l
      | objs when String.Set.is_empty variants -> objs
      | objs -> List.filter (fun o -> String.Set.mem (variant o) variants) objs
      in
      let objs = cobjs_for_dep dep i in
      match List.filter sat_obj objs with
      | [] -> (* Try to look for a cmi file *)
          let sat_cmi o = is_kind Cmi o && sat o in
          try_select_variants @@ List.filter sat_cmi objs
      | objs ->
          match List.filter in_archive objs with
          | [] -> try_select_variants objs
          | ars -> try_select_variants ars (* favour archives *)
  end

  type res = t String.Map.t

  let add_obj res deps acc o =
    (* When we add [o] to the resolution we may add new objects that
       need resolving [deps] because [o] may be part of a library
       archive. *)
    let rec loop res deps = function
    | [] -> (res, deps) :: acc
    | o :: os ->
        match String.Map.find (name o) res with
        | o' ->
            if String.equal (path o) (path o') then loop res deps os else acc
        | exception Not_found ->
            let add_dep acc (n, digest as d) = match String.Map.find n res with
            | exception Not_found -> d :: acc
            | o ->
                match digest, iface_digest o with
                | Some d, Some d' when not (Digest.equal d d') -> raise Exit
                | _ -> acc
            in
            match List.fold_left add_dep [] (iface_deps o) with
            | exception Exit -> acc
            | ds -> loop (String.Map.add (name o) o res) (ds :: deps) os
    in
    loop res deps (path_loads o)

  let add_root_alt acc cobjs =
    let rec loop res deps = function
    | [] -> (res, deps) :: acc
    | o :: os ->
        match add_obj res deps [] o with
        | [] -> acc  (* inconsistent root objects *)
        | [(res, deps)] -> loop res deps os
        | _ -> assert false
    in
    loop String.Map.empty [] cobjs

  let rec resolve_deps = fun ~variants ~sat ~kind idx ~root_alts ->
    let rec finish_next_todo acc todo = match todo with
    | [] ->
        let acc = List.find_all (fun r -> not (String.Map.is_empty r)) acc in
        begin match acc with
        | [] ->
            (* Humpf not very user friendly *)
            Error (strf "No consistent load sequence could be found")
        | acc -> Ok acc
        end
    | (res, deps) :: todo -> loop acc todo res deps
    and loop acc todo res = function
    | ((n, digest as d) :: ds) :: rest ->
        begin match String.Map.find n res with
        | o ->
            begin match digest, iface_digest o with
            | Some d, Some d' when not (Digest.equal d d') ->
                finish_next_todo acc todo
            | _ -> loop acc todo res (ds :: rest)
            end
        | exception Not_found ->
            match Index.cobjs_for_dep_res ~variants ~sat ~kind d idx with
            | [] ->
                Error (strf "Dependency %a cannot be resolved" pp_dep d)
            | objs ->
                match List.fold_left (add_obj res (ds :: rest)) [] objs with
                | [] -> finish_next_todo acc todo
                | (res, deps) :: ress ->
                    let todo = List.rev_append ress todo in
                    loop acc todo res deps
        end
    | [] :: [] -> finish_next_todo (res :: acc) todo
    | [] :: rest -> loop acc todo res rest
    | [] -> assert false
    in
    let todo = List.fold_left add_root_alt [] root_alts in
    finish_next_todo [] todo

  let fold_res res f acc =
    (* Topological sort by depth first exploration of the DAG. *)
    let get res n = match String.Map.find n res with
    | exception Not_found -> invalid_arg (strf "Undefined dep name %s" n)
    | o -> o
    in
    let rec loop seen acc = function
    | (o :: os as l) :: todo ->
        let n = name o in
        begin match String.Set.mem (name o) seen with
        | true -> loop seen acc (os :: todo)
        | false ->
            let seen = String.Set.add n seen in
            let add_dep acc (n, _) = match String.Set.mem n seen with
            | true -> (* early filter *) acc
            | false -> get res n :: acc
            in
            let deps =
              let add_path_loads_as_dep acc l = to_dep l :: acc in
              List.fold_left add_path_loads_as_dep (iface_deps o) (path_loads o)
            in
            match List.fold_left add_dep [] deps with
            | [] (* early filter *) -> loop seen (f o acc) (os :: todo)
            | deps -> loop seen acc (deps :: l :: todo)
        end
    | [] :: (o :: os) :: todo -> loop seen (f o acc) (os :: todo)
    | [] :: ([] :: todo) -> loop seen acc todo
    | [] :: [] -> acc
    | [] -> assert false
    in
    let objs = List.rev_map snd @@ String.Map.bindings res in
    loop String.Set.empty acc (objs :: [])

  let loads ~variants ~sat ~kind idx ~root_alts =
    match resolve_deps ~variants ~sat ~kind idx ~root_alts with
    | Error _ as e -> e
    | Ok ress ->
        let add_path (seen, ps as acc) o =
          let p = path o in
          if String.Set.mem p seen then acc else
          (String.Set.add p seen, p :: ps)
        in
        let add_res acc res =
          let robjs = fold_res res List.cons [] in
          let _, loads = List.fold_left add_path (String.Set.empty, []) robjs in
          loads :: acc
        in
        Ok (List.fold_left add_res [] ress)
end

module Pkg = struct

  (* Packages *)

  type t = Cobj.pkg_id

  let log_file_err ~err file e = err.Log.f "%s: %s" file e

  let of_dir ?(err = Log.err) dir =
    let ocaml_pkg () = match Cmd.read ["ocamlc"; "-where"] with
    | Ok p -> "ocaml", String.trim p
    | Error (c, err) -> failwith (strf "ocaml: exited with [%d]: %s" c err)
    in
    let add_pkg acc sub =
      let file = Filename.concat dir sub in
      try match Sys.is_directory file with
      | false -> acc
      | true when String.equal sub "ocaml" -> acc
      | true -> (sub, file) :: acc
      with Sys_error e -> log_file_err ~err file e; acc
    in
    try
      let pkgs = Array.fold_left add_pkg [] (Sys.readdir dir) in
      let pkgs = ocaml_pkg () :: pkgs in
      List.sort compare @@ pkgs
    with
    | Sys_error e | Failure e -> err.Log.f "%s" e; []

  let fold_pkg_files ?(err = Log.err) f acc (pkg_name, dir) =
    let rec loop acc = function
    | [] -> acc
    | d :: dirs ->
        try
          let rec fold_dir acc dirs = function
          | [] -> loop acc dirs
          | base :: fs ->
              let file = Filename.concat d base in
              try match Sys.is_directory file with
              | true -> fold_dir acc (file :: dirs) fs
              | false -> fold_dir (f acc file) dirs fs
              with
              | Sys_error e -> log_file_err ~err file e; fold_dir acc dirs fs
          in
          fold_dir acc dirs (Array.to_list @@ Sys.readdir d)
        with
        | Sys_error e -> log_file_err ~err d e; loop acc dirs
    in
    loop acc [dir]

  let find_cobjs ?(err = Log.err) ?(acc = []) pkg_id =
    let add_file acc file = match Cobj.add_file ~pkg_id acc file with
    | Error e -> err.Log.f "%s" e; acc
    | Ok acc -> acc
    in
    fold_pkg_files ~err add_file acc pkg_id

  let equal = ( = )
  let compare = Cobj.pkg_compare
  let pp = Cobj.pp_pkg_id
  let pp_name ppf (n, _) = Fmt.string ppf n

  module P = struct
    type nonrec t = t
    let equal = equal
    let compare = compare
  end
  module Set = Set.Make (P)
  module Map = Map.Make (P)

  (* Signatures *)

  type signature = Digest.t

  external caml_string_set_64 :
    bytes -> int -> int64 -> unit = "%caml_string_set64"

  let digest_mtimes ?(err = Log.err) paths =
    let mtime_to_string m =
      let b = Bytes.create 8 in
      caml_string_set_64 b 0 (Int64.bits_of_float m);
      Bytes.unsafe_to_string b
    in
    let rec add_mtime acc p =
      try (mtime_to_string @@ (Unix.stat p).Unix.st_mtime) :: acc with
      | Unix.Unix_error (Unix.EINTR, _, _) -> add_mtime acc p
      | Unix.Unix_error (e, _, _) ->
          log_file_err ~err p (Unix.error_message e); acc
    in
    let paths = List.sort String.compare paths in
    let mtimes = List.fold_left add_mtime [] paths in
    Digest.string @@ String.concat "" mtimes

  let signature ?(err = Log.err) pkg
    =
    let add_cobj acc file =
      if String.Set.mem (snd (File.cut_ext file)) Cobj.exts
      then file :: acc else acc
    in
    digest_mtimes ~err @@ fold_pkg_files ~err add_cobj [] pkg

  (* Information *)

  type info = { signature : signature; cobjs : Cobj.t list }
  let info ~signature ~cobjs = { signature; cobjs }
  let info_signature i = i.signature
  let info_cobjs i = i.cobjs

  let pp_info ppf i =
    let pp_cobj ppf c =
      Fmt.pf ppf "@[%a %s %a@]"
        Digest.pp_opt (Cobj.iface_digest c) (Cobj.name c)
        Fmt.faint (Cobj.path c)
    in
    Fmt.pf ppf "@[<v>| signature: %a@,| cobjs:@,  @[<v>%a@]@]"
      Digest.pp i.signature (Fmt.list pp_cobj)
      (List.sort Cobj.ui_compare i.cobjs)

  (* Databases *)

  type db = info Map.t

  let log_progress ~note ~progress pkg =
    if progress then
      note.Log.f "[%a] %a" (Fmt.tty_str ~mode:"32") "INDEX" pp pkg

  let log_indexing ~note =
    note.Log.f "[%a] In progress..." (Fmt.tty_str ~mode:"32") "INDEXING"

  let db ?(err = Log.err) ?(note = Log.nil) ?(progress = false)
      ?(init = Map.empty) pkgs
    =
    let add_pkg acc pkg =
      let signature = signature ~err pkg in
      let cobjs = (log_progress ~note ~progress pkg; find_cobjs ~err pkg) in
      let info = info ~signature ~cobjs in
      Map.add pkg info acc
    in
    log_indexing ~note;
    List.fold_left add_pkg init pkgs

  let db_to_name_db db =
    let add_name (n, _ as id) info acc = String.Map.add n (id, info) acc in
    Map.fold add_name db String.Map.empty

  let db_to_cobj_index db =
    let add_cobjs _ i acc = Cobj.Index.of_cobjs ~init:acc (info_cobjs i) in
    Map.fold add_cobjs db Cobj.Index.empty

  type diff =
  [ `New of t * signature
  | `Changed of t * signature
  | `Gone of t ]

  let pp_diff ppf = function
  | `New (p, _) ->   Fmt.pf ppf "[NEW  ] %a" pp p
  | `Changed (p, _) -> Fmt.pf ppf "[STALE] %a" pp p
  | `Gone p ->  Fmt.pf ppf "[GONE ] %a" pp p

  let diff m state =
    let rec loop acc unseen = function
    | [] ->
        let add_unseen pkg acc = `Gone pkg :: acc in
        List.rev (Set.fold add_unseen unseen acc)
    | (pkg, sgn) :: ps ->
        match Map.find pkg m with
        | exception Not_found -> loop (`New (pkg, sgn) :: acc) unseen ps
        | i ->
            let unseen = Set.remove pkg unseen in
            match Digest.equal (info_signature i) sgn with
            | true -> loop acc unseen ps
            | false -> loop (`Changed (pkg, sgn) :: acc) unseen ps
    in
    let unseen = Map.fold (fun k v acc -> Set.add k acc) m Set.empty in
    loop [] unseen state

  let update ?(err = Log.err) ?(note = Log.nil) ?(progress = false) m ds =
    if ds = [] then m else
    let rec loop m = function
    | [] -> m
    | d :: ds ->
      match d with
      | `Gone pkg -> loop (Map.remove pkg m) ds
      | `New (pkg, signature)
      | `Changed (pkg, signature) ->
          let cobjs = (log_progress ~note ~progress pkg; find_cobjs ~err pkg) in
          let info = info ~signature ~cobjs in
          loop (Map.add pkg info m) ds
    in
    (log_indexing ~note; loop m ds)
end

module Conf = struct
  let get_env k = match Sys.getenv k with
  | "" -> None | exception Not_found -> None | v -> Some v

  let ( / ) = Filename.concat
  let in_prefix_path dir =
    Filename.(dirname @@ dirname Sys.executable_name) / dir

  let libdir_env = "OMOD_LIBDIR"
  let get_libdir libdir = match libdir with
  | Some l -> l | None ->
      match get_env libdir_env with
      | Some l -> l | None -> in_prefix_path "lib"

  let cache_env = "OMOD_CACHE"
  let get_cache cache = match cache with
  | Some l -> l | None ->
      match get_env cache_env with
      | Some l -> l | None -> in_prefix_path ("var" / "cache" / "omod")

  type t = { cache : Omod.fpath; libdir : Omod.fpath }

  let v ?cache ?libdir () =
    try
      let cache = get_cache cache in
      let libdir = get_libdir libdir in
      Ok { cache; libdir; }

    with
    | Failure e -> Error e

  let cache c = c.cache
  let libdir c = c.libdir
  let pp ppf c = Fmt.pf ppf "@[<v>cache: %s@,libdir: %s@]" c.cache c.libdir
end

module Cache = struct
  type t = { pkgs : Pkg.db; }
  let v ~pkgs = { pkgs }
  let pkgs c = c.pkgs
  let file conf = Filename.concat (Conf.cache conf) "cache"
  let codec = Codec.v ~id:"cache"
  let read conf ~force ~err =
    let file = file conf in
    match File.exists file with
    | Error _ as e -> e
    | Ok false -> Ok None
    | Ok true ->
        match Codec.read codec file with
        | Error m as e -> if force then (err.Log.f "%s" m; Ok None) else e
        | Ok c -> Ok (Some c)

  let write conf c = match Dir.create ~path:true (Conf.cache conf) with
  | Error _ as e -> e
  | Ok _ -> Codec.write codec (file conf) c

  let clear conf = match File.delete (file conf) with
  | Error _ as e -> e | Ok _ -> Ok ()

  let _refresh ~err ~note ~progress conf = function
  | None ->
      let pkgs = Pkg.of_dir ~err (Conf.libdir conf) in
      let db = Pkg.db ~err ~note ~progress pkgs in
      let c = { pkgs = db } in
      (match write conf c with | Error _ as e -> e | Ok () -> Ok c)
  | Some c ->
      let pkgs = Pkg.of_dir ~err (Conf.libdir conf) in
      let sigs = List.rev_map (fun p -> (p, Pkg.signature ~err p)) pkgs in
      match Pkg.diff c.pkgs sigs with
      | [] -> Ok c
      | diffs ->
          let pkgs = Pkg.update ~err ~note ~progress c.pkgs diffs in
          let c = { pkgs } in
          (match write conf c with | Error _ as e -> e | Ok () -> Ok c)

  let get ?(err = Log.err) ?(note = Log.nil) ?(progress = false)
      conf ~force ~trust
    =
    match read conf ~force ~err with
    | Error e when not force ->
        (* A bit ugly but let's make this easy *)
        Error (e ^ "\nTry to run with '-f' to force the cache")
    | Error _ as e -> e
    | Ok c when not trust -> _refresh ~err ~note ~progress conf c
    | Ok (Some c) -> Ok c
    | Ok None ->
        if force then _refresh ~err ~note ~progress conf None else
        Error (strf "Cannot trust cache, %s does not exist" (file conf))

  let status ?(err = Log.err) conf c =
    let pkgs = Pkg.of_dir ~err (Conf.libdir conf) in
    let sigs = List.map (fun p -> (p, Pkg.signature ~err p)) pkgs in
    match c with
    | Some c -> Pkg.diff c.pkgs sigs
    | None -> List.rev (List.rev_map (fun (p, sg) -> `New (p, sg)) sigs)
end