Source file registry.ml

open Import

module File = struct
  type t =
    { path : string
    ; contents : string
    }
end

let _pid_of_path path =
  Filename.basename path
  |> Filename.chop_suffix_opt ~suffix:".pid"
  |> Option.bind ~f:Int.of_string
;;

module Dune = struct
  module T = struct
    type t =
      { root : string
      ; pid : int
      ; where : Where.t
      }

    let compare t { root; pid; where } =
      let open Ordering.O in
      let= () = Int.compare t.pid pid in
      let= () = String.compare t.root root in
      Where.compare t.where where
    ;;

    let to_dyn { root; pid; where } =
      let open Dyn in
      record [ "root", string root; "pid", int pid; "where", Where.to_dyn where ]
    ;;
  end

  include T
  module C = Comparable.Make (T)
  module Set = C.Set

  let create ~where ~root ~pid = { where; root; pid }
  let root t = t.root
  let where t = t.where
  let pid t = t.pid
  let filename dune = Printf.sprintf "%d.csexp" dune.pid

  let sexp : t Conv.value =
    let open Conv in
    let to_ (where, root, pid) = { where; root; pid } in
    let from { where; root; pid } = where, root, pid in
    let where = field "where" (required Where.sexp) in
    let root = field "root" (required string) in
    let pid = field "pid" (required int) in
    iso (record (three where root pid)) to_ from
  ;;

  type error =
    | Of_sexp of Conv.error
    | Csexp of
        { position : int
        ; message : string
        }

  exception E of error

  let () =
    Printexc.register_printer (function
      | E (Of_sexp e) -> Some (Dyn.to_string (Conv.dyn_of_error e))
      | E (Csexp { position; message }) ->
        Some
          (Dyn.to_string
             (let open Dyn in
              record [ "message", string message; "position", int position ]))
      | _ -> None)
  ;;

  let of_file (f : File.t) =
    match Csexp.parse_string f.contents with
    | Error (position, message) -> Error (Csexp { position; message })
    | Ok s ->
      (match Conv.of_sexp sexp ~version:(0, 0) s with
       | Ok s -> Ok s
       | Error e -> Error (Of_sexp e))
  ;;
end

module Config = struct
  type t = Xdg.t

  let watch_dir t =
    let dir =
      match Xdg.runtime_dir t with
      | Some runtime -> runtime
      | None -> Xdg.data_dir t
    in
    Filename.concat dir "dune/rpc"
  ;;

  let create x = x

  let register t dune =
    let file =
      let contents = Conv.to_sexp Dune.sexp dune |> Csexp.to_string in
      let path = Filename.concat (watch_dir t) (Dune.filename dune) in
      { File.contents; path }
    in
    `Caller_should_write file
  ;;
end

type nonrec t =
  { config : Config.t
  ; mutable last_mtime : float option
  ; mutable current : Dune.t list
  }

let create config = { config; last_mtime = None; current = [] }
let current t = t.current

module Refresh = struct
  type t =
    { added : Dune.t list
    ; removed : Dune.t list
    ; errored : (string * exn) list
    }

  let empty = { added = []; removed = []; errored = [] }
  let added t = t.added
  let removed t = t.removed
  let errored t = t.errored
end

module Poll
    (Fiber : sig
       type 'a t

       val return : 'a -> 'a t
       val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t

       module O : sig
         val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
         val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
       end
     end)
    (IO : sig
       val scandir : string -> (string list, exn) result Fiber.t
       val stat : string -> ([ `Mtime of float ], exn) result Fiber.t
       val read_file : string -> (string, exn) result Fiber.t
     end) =
struct
  open Fiber.O

  let ( let** ) x f =
    let* x = x in
    match x with
    | Ok s -> f s
    | Error e -> Fiber.return (Error e)
  ;;

  let ( let++ ) x f =
    let+ x = x in
    match x with
    | Ok s -> Ok (f s)
    | Error e -> Error e
  ;;

  let poll t =
    let dir = Config.watch_dir t.config in
    let** (`Mtime mtime) = IO.stat dir in
    let skip =
      match t.last_mtime with
      | Some last_mtime -> last_mtime >= mtime
      | None ->
        t.last_mtime <- Some mtime;
        false
    in
    if skip
    then Fiber.return (Ok Refresh.empty)
    else
      let++ results =
        let** contents = IO.scandir dir in
        let contents =
          List.filter contents ~f:(fun fname -> fname <> "." && fname <> "..")
        in
        let+ res =
          Fiber.parallel_map contents ~f:(fun fname ->
            let path = Filename.concat dir fname in
            let+ contents = IO.read_file path in
            ( path
            , match contents with
              | Error e -> Error e
              | Ok contents ->
                let file = { File.contents; path } in
                (match Dune.of_file file with
                 | Ok _ as s -> s
                 | Error e -> Error (Dune.E e)) ))
        in
        Ok res
      in
      let new_current, errored =
        List.partition_map results ~f:(fun (file, res) ->
          match res with
          | Ok s -> Left s
          | Error e -> Right (file, e))
      in
      let current = t.current in
      t.current <- new_current;
      let module Set = Dune.Set in
      let new_current = Set.of_list new_current in
      let current = Set.of_list current in
      { Refresh.added = Set.to_list (Set.diff new_current current)
      ; removed = Set.to_list (Set.diff current new_current)
      ; errored
      }
  ;;
end