Source file context_cache.ml

(*
 * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
 * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
 * Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Astring
open Action.Syntax

let src = Logs.Src.create "functoria.cache" ~doc:"functoria library"

module Log = (val Logs.src_log src : Logs.LOG)

type t = string array

let empty = [| "" |]
let is_empty t = t = empty

let write file argv =
  Log.info (fun m ->
      m "Preserving arguments in %a:@ %a" Fpath.pp file
        Fmt.Dump.(array string)
        argv);
  (* Only keep args *)
  let args = List.tl (Array.to_list argv) in
  let args = List.map String.Ascii.escape args in
  let args = String.concat ~sep:"\n" args ^ "\n" in
  Action.write_file file args

let read file =
  Log.info (fun l -> l "reading cache %a" Fpath.pp file);
  let* is_file = Action.is_file file in
  if not is_file then Action.ok empty
  else
    let* args = Action.read_file file in
    let args = String.cuts ~sep:"\n" args in
    (* remove trailing '\n' *)
    let args = List.rev (List.tl (List.rev args)) in
    (* Add an empty command *)
    let args = "" :: args in
    let args = Array.of_list args in
    try
      let args =
        Array.map
          (fun x ->
            match String.Ascii.unescape x with
            | Some s -> s
            | None -> Fmt.failwith "%S: cannot parse" x)
          args
      in
      Action.ok args
    with Failure e -> Action.error e

let peek t term =
  match Cmdliner.Cmd.eval_peek_opts ~argv:t term with
  | Some c, _ | _, Ok (`Ok c) -> Some c
  | _ -> None

let merge t term =
  let cache = match peek t term with None -> Context.empty | Some c -> c in
  let f term = Context.merge ~default:cache term in
  Cmdliner.Term.(const f $ term)

let peek_output t = Cli.peek_output t

let file ~name args =
  let build_dir = Fpath.parent args.Cli.config_file in
  match args.Cli.context_file with
  | Some f -> f
  | None -> Fpath.(build_dir / name / "context")