seppo/lib/make.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

(*
 * https://doi.org/10.1017/S0956796820000088
 * <= https://www.youtube.com/watch?v=MjWx_qfEQXg
 * <= https://lobste.rs/s/umdeiu/memo_incremental_computation_library
*)

let ( let* ) = Result.bind

module Jig = struct

  let make = String.split_on_char '%'

  let cut p s =
    let rx = "^" ^ (p |> String.concat {|\(.*\)|}) ^ "$"
             |> Str.regexp in
    if Str.string_match rx s 0
    then (
      let n = p |> List.length in
      Some (List.init
              (n-1)
              (fun i -> Str.matched_group (i+1) s)))
    else None

  let paste jig v : string option =
    assert (jig |> List.length <= 1 + (v |> List.length));
    match jig with
    | [] -> None
    | [s]-> Some s (* no % substitutions are totally fine *)
    | hd :: tl ->
      Some (List.fold_left2 (fun lst a b -> a :: b :: lst) [hd] tl v
            |> List.rev
            |> String.concat "")
end

type remake =
  | Outdated (* remake target if dependencies are more recent *)
  | Missing  (* remake target ONLY if missing *)

(** a single rule *)
type t = {
  target        : string; (* should the target be separate to build List.assoc tuples? *)
  prerequisites : string list;
  fresh         : remake;
  command       : (string -> t list -> t -> string ->
                   (* return a different name to create a smylink *)
                   (string, string) result);
}

let src_from (r : t) t =
  assert (1 <= (r.prerequisites |> List.length));
  let j_src = r.prerequisites |> List.hd |> Jig.make in
  let j_dst = r.target |> Jig.make in
  assert (3 == (j_src |> List.length));
  assert (3 == (j_dst |> List.length));
  let v = t |> Jig.cut j_dst |> Option.value ~default:[] in
  let src = v |> Jig.paste j_src |> Option.value ~default:"⚠️" in
  src,j_dst,v

let dot oc (all : t list) =
  (* escape for https://graphviz.org/doc/info/lang.html *)
  let esc s =
    s
    |> String.split_on_char '%'
    |> String.concat {|\%|}
  in
  Printf.fprintf oc "%s"
    (esc {|digraph "#Seppo" {
  label = "#Seppo files
https://Seppo.Social";
  rankdir=TD;
|});
  all |> List.fold_left (fun _ r ->
      r.prerequisites |> List.fold_left (fun _ p ->
          Printf.fprintf oc {|  "%s" -> "%s"|} (esc p) (esc r.target);
          Printf.fprintf oc "%s" ";\n";
          ()) ();
      () ) ();
  Printf.fprintf oc "%s" "}\n";
  Ok ()

module M2 = struct
  let match_rule (fn : string) m (r : t) =
    match m with
    | None ->
      let j_dst = r.target |> Jig.make in
      (match fn |> Jig.cut j_dst with
       | None   ->
         Logr.debug (fun m -> m "%s.%s %s ~ %s" "Make.M2" "match_rule" fn r.target);
         None
       | Some v ->
         Logr.debug (fun m -> m "%s.%s found %s" "Make.M2" "match_rule" r.target);
         Some (r,v))
    | Some _ as m -> m

  let find_rule rules fn : (t * string list) option =
    rules |> List.fold_left (match_rule fn) None

  let time ?(default = 0.) fn =
    try (Unix.stat fn).st_mtime
    with _ -> default

  let rec fo_make lvl rules x fn : (float,string) result =
    let t0 = Sys.time() in
    Logr.debug (fun m -> m "%s.%s %d <%s>" "Make.M2" "fo_make" lvl fn);
    let* x' = x in
    let r = match fn |> find_rule rules with
      | None ->
        if fn |> File.exists
        then
          (Logr.debug (fun m -> m "%s.%s no rule but target exists: %s" "Make.M2" "fo_make" fn);
           Ok (time fn))
        else Error ("no rule to make target: " ^ fn)
      | Some (r,v) ->
        let add init v =
          match v with
          | None   -> init
          | Some v -> v :: init in
        let* t' = r.prerequisites
                  |> List.fold_left (fun init pq ->
                      let jig_pq = pq |> Jig.make in
                      v |> Jig.paste jig_pq |> add init) []
                  |> List.fold_left (fo_make (lvl+1) rules) x in
        let tf = time fn in
        if tf >= t'
        then
          (Logr.debug (fun m -> m "%s.%s up to date: %s" "Make.M2" "fo_make" fn);
           Ok (tf |> max x'))
        else
          let _ = fn |> Filename.dirname |> File.mkdir_p File.pDir in
          let* _ = fn |> r.command "-" rules r in
          (* create a softlink in case? *)
          Ok (time fn)
    in
    Logr.info (fun m -> m "%s.%s %s dt=%.3fs"  "Make.M2" "fo_make"  fn (Sys.time() -. t0));
    r

  let make rules fn =
    match fo_make 0 rules (Ok 1.0) fn with
    | Error _ as e -> e
    | Ok _         -> Ok fn
end

module M1 = struct
  let make ?(pre = "") (rs : t list) (fn : string) : (string, 'a) result =
    let module MakeMapT = struct
      type t = String.t
      let compare a b = String.compare a b
    end in
    let module MakeMap = Map.Make(MakeMapT) in
    let rec make' pre (rm : t MakeMap.t) fn =
      let t0 = Sys.time() in
      let ( >>= ) = Result.bind in
      let find_rule fn : t option = MakeMap.find_opt fn rm in (* TODO should we block anything starting with / or containing .. ? *)
      match fn |> find_rule with
      | None -> (
          match File.mtime_0 fn <= 0. with
          | true  -> Error ("no rule to make target `" ^ fn ^ "'")
          | false -> Ok fn)
      | Some ({target; prerequisites; fresh; command} as rule) ->
        assert (target = fn);
        let rec visit_siblings num sibs _ =
          match sibs with
          | [] -> Ok ""
          | hd :: tl ->
            Logr.debug (fun m -> m "%s%s.%s visit_sibling %d %s" pre "Make" "make" num hd);
            make' (pre ^ "  ") rm hd (* depth first *)
            >>= visit_siblings (succ num) tl
        in
        if match fresh with
          | Missing -> target |> File.exists
          | Outdated ->
            (* @TODO handle missing target rules Error *)
            let _ = visit_siblings 0 prerequisites "" in
            let tta = File.mtime_0 target in
            let rec is_fresh = function
              | [] -> true
              | hd :: tl ->
                let b = (hd |> File.mtime_0 <= tta) in
                Logr.debug (fun m -> m "%s  %s %s is %s than %s" pre (if b then "ok" else "!!") target (if b then "FRESHER" else "OLDER") hd);
                b && (is_fresh tl)
            in
            is_fresh prerequisites
        then
          Ok target
        else (
          Logr.debug (fun m -> m "%s  %s building" pre target);
          let* _ = target |> Filename.dirname |> File.mkdir_p File.pDir in
          let r = match target |> command pre rs rule
            with
            | Error e' as e ->
              Logr.err (fun m -> m "%s %s.%s %s: %s" E.e1019 "Make" "make" target e');
              e
            | Ok re ->
              if not (re = "" || re |> String.equal target)
              then
                Unix.(
                  Logr.debug (fun m -> m "%s.%s 0 ls -s %s %s" "Make" "make" re target);
                  (try unlink target;
                   with | Unix_error(ENOENT, "unlink", _) -> ());
                  try
                    Logr.debug (fun m -> m "%s.%s 1 ln -s %s %s" "Make" "make" re target);
                    let up = re |> St.updir in
                    symlink (up ^ re) target;
                    Logr.debug (fun m -> m "%s.%s 2 ln -s %s %s" "Make" "make" (up ^ re) target);
                  with | e -> Logr.err (fun m -> m "%s %s.%s %a" E.e1030 "Make" "make" St.pp_exc e);
                );
              Ok target in
          Logr.info (fun m -> m "%s.%s %s dt=%.3fs"  "Make" "make"  fn (Sys.time() -. t0));
          r
        )
    in
    let rm = rs |> List.fold_left (fun init r -> MakeMap.add r.target r init) MakeMap.empty in
    fn |> make' pre rm
end

let copy dst src : t =
  { target         = dst;
    prerequisites  = [ src ];
    fresh          = Outdated;
    command        = fun _ _ _ t ->
      File.(src |> in_channel (fun ic ->
          let _ = t |> Filename.dirname |> mkdir_p pDir in
          t |> out_channel_replace (fun oc ->
              ic |> copy_channel oc;
              Ok t)
        ))
  }

(** Manage actions from dependencies, file/timestamp based.

    Similar POSIX make.

    pre: prefix
    rs:  rules
    fn:  the file to keep up to date
*)
let make ?(pre = "") (rs : t list) (fn : string) : (string, 'a) result =
  (if false
   then M2.make
   else M1.make ~pre) rs fn