Source file dune_action_plugin.ml

open Import

module V1 = struct
  module Path = Path
  module Glob = Dune_glob.V1
  open Protocol

  module Execution_error = struct
    exception E of string

    let raise string = raise (E string)

    let raise_on_fs_error = function
      | Error message -> raise message
      | Ok result -> result
    ;;
  end

  module Fs : sig
    val read_directory : string -> (string list, string) result
    val read_file : string -> (string, string) result
    val write_file : string -> string -> (unit, string) result
  end = struct
    let catch_system_exceptions f ~name =
      try Ok (f ()) with
      | Unix.Unix_error (error, syscall, arg) ->
        let error = Unix_error.Detailed.create error ~syscall ~arg in
        Error (name ^ ": " ^ Unix_error.Detailed.to_string_hum error)
      | Sys_error error -> Error (name ^ ": " ^ error)
    ;;

    let read_directory =
      let rec loop dh acc =
        match Unix.readdir dh with
        | "." | ".." -> loop dh acc
        | s -> loop dh (s :: acc)
        | exception End_of_file -> acc
      in
      fun path ->
        catch_system_exceptions ~name:"read_directory" (fun () ->
          let dh = Unix.opendir path in
          Exn.protect
            ~f:(fun () -> loop dh [] |> List.sort ~compare:String.compare)
            ~finally:(fun () -> Unix.closedir dh))
    ;;

    let read_file path =
      catch_system_exceptions ~name:"read_file" (fun () -> Io.String_path.read_file path)
    ;;

    let write_file path data =
      catch_system_exceptions ~name:"write_file" (fun () ->
        Io.String_path.write_file path data)
    ;;
  end

  module Stage = struct
    type 'a t =
      { action : unit -> 'a
      ; dependencies : Dependency.Set.t
      ; targets : String.Set.t
      }

    let map (t : 'a t) ~f = { t with action = (fun () -> f (t.action ())) }

    let both (t1 : 'a t) (t2 : 'b t) =
      { action = (fun () -> t1.action (), t2.action ())
      ; dependencies = Dependency.Set.union t1.dependencies t2.dependencies
      ; targets = String.Set.union t1.targets t2.targets
      }
    ;;
  end

  (* Construction inspired by free monad. *)
  type 'a t =
    | Pure of 'a
    | Stage of 'a t Stage.t

  let lift_stage stage = Stage (Stage.map stage ~f:(fun a -> Pure a))

  let rec map (t : 'a t) ~f =
    match t with
    | Pure a -> Pure (f a)
    | Stage at -> Stage (Stage.map ~f:(map ~f) at)
  ;;

  let rec stage (t : 'a t) ~f =
    match t with
    | Pure a -> f a
    | Stage at -> Stage (Stage.map ~f:(stage ~f) at)
  ;;

  let return a = Pure a

  let rec both (t1 : 'a t) (t2 : 'b t) =
    match t1, t2 with
    | Pure a1, _ -> map ~f:(fun a2 -> a1, a2) t2
    | _, Pure a2 -> map ~f:(fun a1 -> a1, a2) t1
    | Stage at1, Stage at2 ->
      Stage (Stage.both at1 at2 |> Stage.map ~f:(fun (am1, am2) -> both am1 am2))
  ;;

  let read_file ~path =
    let path = Path.to_string path in
    let action () = Fs.read_file path |> Execution_error.raise_on_fs_error in
    lift_stage
      { action
      ; dependencies = Dependency.Set.singleton (File path)
      ; targets = String.Set.empty
      }
  ;;

  let write_file ~path ~data =
    let path = Path.to_string path in
    let action () = Fs.write_file path data |> Execution_error.raise_on_fs_error in
    lift_stage
      { action; dependencies = Dependency.Set.empty; targets = String.Set.singleton path }
  ;;

  (* TODO jstaron: If program tries to read empty directory, dune does not copy
     it to `_build` so we get a "No such file or directory" error. *)
  let read_directory_with_glob ~path ~glob =
    let path = Path.to_string path in
    let action () =
      Fs.read_directory path
      |> Execution_error.raise_on_fs_error
      |> List.filter ~f:(Glob.test glob)
    in
    lift_stage
      { action
      ; dependencies =
          Dependency.Set.singleton (Glob { path; glob = Glob.to_string glob })
      ; targets = String.Set.empty
      }
  ;;

  let rec run_by_dune t context =
    match t with
    | Pure () -> Context.respond context Done
    | Stage at ->
      let allowed_targets = Context.targets context in
      let disallowed_targets = String.Set.diff at.targets allowed_targets in
      (match String.Set.to_list disallowed_targets with
       | [] -> ()
       | [ t ] ->
         Execution_error.raise
           (Printf.sprintf
              "%s is written despite not being declared as a target in dune file. To \
               fix, add it to target list in dune file."
              t)
       | ts ->
         Execution_error.raise
           (Printf.sprintf
              "Following files were written despite not being declared as targets in \
               dune file:\n\
               %sTo fix, add them to target list in dune file."
              (ts |> String.concat ~sep:"\n")));
      let prepared_dependencies = Context.prepared_dependencies context in
      let required_dependencies =
        Dependency.Set.diff at.dependencies prepared_dependencies
      in
      if Dependency.Set.is_empty required_dependencies
      then run_by_dune (at.action ()) context
      else Context.respond context (Need_more_deps required_dependencies)
  ;;

  (* If executable is not run by dune, assume that all dependencies are already
     prepared and no target checking is done. *)
  let rec run_outside_of_dune t =
    match t with
    | Pure () -> ()
    | Stage at -> run_outside_of_dune (at.action ())
  ;;

  let do_run t =
    match Protocol.Context.create () with
    | Run_outside_of_dune -> run_outside_of_dune t
    | Error message ->
      Execution_error.raise
        (Printf.sprintf
           "Error during communication with dune. %s Did you use different dune version \
            to compile the executable?"
           message)
    | Ok context -> run_by_dune t context
  ;;

  let run t =
    try
      do_run t;
      exit 0
    with
    | Execution_error.E message ->
      prerr_endline message;
      exit 1
  ;;

  module O = struct
    let ( let+ ) at f = map at ~f
    let ( and+ ) = both
  end

  module Private = struct
    module Protocol = Protocol

    let do_run = do_run

    module Execution_error = Execution_error
  end
end

module Private = V1.Private