Source file fs_simulation.ml

open Plebeia
open Result_lwt.Infix
open Fs_intf
open Fs_impl

module Simulation(Name : NAME) = struct
  module Path = Path(Name)

  type name = Name.t

  (* Assumes [Name.t]'s polymorphic equality *)
  module Map = Map.Make(struct type t = name let compare (x : name) y = compare x y end)

  type model_tree =
    | File of Value.t
    | Dir of model_tree Map.t

  (* zipper *)
  type raw_cursor = Z of model_tree * (name * model_tree Map.t) list

  type cursor = raw_cursor

  type view = model_tree

  type hash = string

  let rec pp_model_tree_map ppf m =
    Utils.Format.list ";@ " (fun ppf (k, v) -> Format.fprintf ppf "@[<2>%a=@,%a@]" Name.pp k pp_view v)
      ppf (Map.bindings m)

  and pp_view ppf = function
    | File v -> Format.fprintf ppf "File %a" Value.pp v
    | Dir m -> Format.fprintf ppf "Dir [ %a ]" pp_model_tree_map m

  let pp_trail ppf trail =
    Format.fprintf ppf "trail: @[%a@]"
      (Utils.Format.list ";@ " (fun ppf (k, m) -> Format.fprintf ppf "(@[<2>%a:@ %a@])" Name.pp k pp_model_tree_map m)) trail

  let pp_cursor ppf (Z (t, trail)) =
    Format.fprintf ppf "%a - %a" pp_view t pp_trail trail

  include MakeError(Path)

  module Context = struct end

  let empty _ = Z (Dir Map.empty, [])

  let make c _ = c

  let error_fs e = Error (FS_error e)

  module Op = struct
    include Monad.Make1(struct
        type 'a t = cursor -> (cursor * 'a, Error.t) result

        let return a c = Ok (c, a)

        let bind (aop : 'a t) (f : 'a -> 'b t) : 'b t =
         fun c ->
          match aop c with
          | Error e ->
              Error e
          | Ok (c, a) ->
              f a c
      end)

    let fail e _ = error_fs e

    let get_raw_cursor c = c
    let raw_cursor c = Ok (c,c)

    let context _ = assert false

    let get_path (Z (_, trail)) = List.rev_map fst trail

    let path (Z (_, trail) as c) =
      Ok (c, List.rev_map fst trail)

    let view (Z (v, _) as c) = Ok (c, v)

    let chdir_parent = function
      | Z (_, []) as c -> Ok (c, ())
      | Z (v, (n,rest)::trail) ->
          assert (not @@ Map.mem n rest);
          Ok (Z (Dir (Map.add n v rest), trail), ())

    let rec chdir_root = function
      | Z (_, []) as c -> Ok (c, ())
      | c -> chdir_parent c >>? fun (c,()) -> chdir_root c

    let seek path0 : (cursor * view) t = fun c ->
      let rec seek path (Z (v, trail) as c) =
        match path with
        | [] ->
            Ok (c, (c, v))
        | n :: path ->
            match v with
            | Dir kvs ->
                (match Map.find_opt n kvs with
                 | None -> error_fs (No_such_file_or_directory ("seek", path0))
                 | Some v ->
                     seek path (Z (v, (n, Map.remove n kvs) :: trail)))
            | File _ ->
                error_fs (Is_file ("seek", get_path c))
      in
      seek path0 c

    let seek' path0 : Path.t t = fun c ->
      let rec seek path (Z (v, trail) as c) = match path with
        | [] -> assert false
        | [n] ->
            Ok (c, [n])
        | n :: path ->
            match v with
            | Dir kvs ->
                (match Map.find_opt n kvs with
                 | None -> Ok (c, n::path)
                 | Some v ->
                     seek path (Z (v, (n, Map.remove n kvs) :: trail)))
            | File _ ->
                error_fs (Is_file ("seek'", get_path c))
      in
      seek path0 c

    let chdir ?(dig=false) path0 : unit t = fun c ->
      let rec seek path (Z (v, trail) as c) = match path with
        | [] -> Ok (c, ()) (* v = Dir *)
        | n :: path ->
            match v with
            | Dir kvs ->
                (match Map.find_opt n kvs with
                 | None when dig ->
                     seek path (Z (Dir Map.empty, (n, kvs) :: trail))
                 | None -> error_fs (No_such_file_or_directory ("chdir", get_path c @ [n]))
                 | Some v -> seek path (Z (v, (n, Map.remove n kvs) :: trail)))
            | File _ ->
                error_fs (Is_file ("chdir", get_path c))
      in
      seek path0 c

    (* Perform [f] then recover the original place of the current cursor.
       Unspecified if [cd_parent] or [cd_root] are called inside [f].
    *)
    let with_pushd f c =
      let path0 = get_path c in
      f c >>? fun (c,res) ->
      match Path.is_prefix_of path0 (get_path c) with
      | None ->
          Format.eprintf "with_pushd: %a %a@."
            Path.pp path0
            Path.pp (get_path c);
          assert false
      | Some p ->
          let rec loop c = function
            | 0 -> Ok (c, res)
            | n -> chdir_parent c >>? fun (c, ()) -> loop c (n-1)
          in
          loop c @@ List.length p

    let get p c =
      with_pushd (seek p) c

    let cat path c =
      get path c >>? function
      | (c, (_c, File v)) -> Ok (c, v)
      | (_, (_, Dir _)) -> error_fs (Is_directory ("cat", path))

    let write path0 value c =
      with_pushd (fun c ->
          seek' path0 c >>? fun (c, p) ->
          view c >>? fun (c,v) ->
          let Z (_, trail) = c in
          match v with
          | Dir kvs ->
              begin match p with
                | [] -> assert false
                | k::ks ->
                    match Map.find_opt k kvs with
                    | None ->
                        let rec f = function
                          | [] -> File value
                          | k::ks -> Dir (Map.singleton k (f ks))
                        in
                        Ok (Z (Dir (Map.add k (f ks) kvs), trail), ())
                    | Some (File _) when ks = [] ->
                        (* overwrite *)
                        Ok (Z (Dir (Map.add k (File value) kvs), trail), ())
                    | Some (Dir _) when ks = [] ->
                        error_fs (Is_directory ("write", get_path c))
                    | Some (File _)
                    | Some (Dir _) ->
                        assert false (* should be handled by seek_dir *)
              end
          | File _ ->
              error_fs (Is_file ("write", get_path c))) c

    let unlink path check c =
      with_pushd (fun c ->
          seek' path c >>? fun (c, p) ->
          match p with
          | [] -> assert false
          | [n] ->
              let Z (v, trail) = c in
              begin match v with
              | File _ ->
                  error_fs (Is_file ("unlink", get_path c))
              | Dir kvs ->
                  match Map.find_opt n kvs with
                  | None -> Ok (c, false) (* target does not exist *)
                  | Some v ->
                      let v' = match v with
                        | File _ -> `Leaf v
                        | Dir _ -> `Bud v
                      in
                      check v' >>? fun () ->
                      let c = Z (Dir (Map.remove n kvs), trail) in
                      let rec loop = function
                        | Z (Dir kvs, (_,rest)::trail) when Map.is_empty kvs ->
                            loop (Z (Dir rest, trail))
                        | Z (Dir kvs, []) when Map.is_empty kvs -> Ok (c, true) (* allow Bud (None) at the root *)
                        | c -> Ok (c, true)
                      in
                      loop c
              end
          | _::_ ->
              (* target does not exist *)
              Ok (c, false)) c

    let set path c' c =
      view c' >>? fun (_, v) ->
      match v with
      | Dir kvs when Map.is_empty kvs ->
          unlink path (fun _ -> Ok ()) c >|? fun (c,_) -> (c, ())
      | Dir _ | File _ ->
          with_pushd (fun c ->
              seek' path c >>? fun (c, p) ->
              match c with
              | Z (File _, _) ->
                  error_fs (Is_file ("set", get_path c))
              | Z (Dir kvs, trail) ->
                  begin match p with
                    | [] -> assert false
                    | k::ks ->
                        let rec f = function
                          | [] -> v
                          | k::ks -> Dir (Map.singleton k (f ks))
                        in
                        let ent = f ks in
                        Ok (Z (Dir (Map.add k ent kvs), trail), ())
                  end) c

    let copy from to_ : unit t = fun c ->
      get from c >>? fun (c, (c_from, _v_from)) ->
      set to_ c_from c

    let rm ?(recursive=false) ?(ignore_error=false) path c =
      let check = function
        | `Bud _ when not recursive -> error_fs (Is_directory ("rm", path))
        | _ -> Ok ()
      in
      match unlink path check c with
      | Ok (c, true) -> Ok (c,true)
      | Ok (c, false) when ignore_error -> Ok (c,false)
      | Ok (_, false) -> error_fs (No_such_file_or_directory ("rm", path))
      | Error _ when ignore_error -> Ok (c,false)
      | Error _ as e -> e

    let rmdir ?(ignore_error=false) path c =
      let check = function
        | `Leaf _ -> error_fs (Is_file ("rmdir", path))
        | _ -> Ok ()
      in
      match unlink path check c with
      | Ok (c, true) -> Ok (c,true)
      | Ok (c, false) when ignore_error -> Ok (c,false)
      | Ok (_, false) -> error_fs (No_such_file_or_directory ("rm", path))
      | Error _ when ignore_error -> Ok (c,false)
      | Error _ as e -> e

    (* We assume that Buds and directories correspond with each other *)
    let ls_no_lwt : Path.t -> (Name.t * cursor) list t =
      fun path0 c ->
      with_pushd (fun c ->
          seek path0 c >>? function
          | Z (File _, _), _ ->
              error_fs (Is_file ("ls", path0))
          | (Z (Dir m, trail) as c), _ ->
              let rec f = function
                | [] -> []
                | (k,v)::kvs ->
                    (k, Z (v, (k, Map.remove k m) :: trail)) :: f  kvs
              in
              Ok (c, f @@ Map.bindings m)) c

    let do_then f (g : 'a t) = fun c -> f c; g c

    let run c op = op c

    let compute_hash c = Ok (c, "dummy")

    let may_forget c = Ok (c, ())
  end

  module Op_lwt = struct
    include Monad.Make1(struct
        type 'a t = cursor -> (cursor * 'a, Error.t) result Lwt.t

        let return a c = Lwt.return_ok (c, a)

        let bind (aop : 'a t) (f : 'a -> 'b t) : 'b t =
          fun c ->
          Lwt.bind (aop c) (function
              | Error _ as e -> Lwt.return e
              | Ok (c, a) -> f a c)
      end)

    let lift : 'a Op.t -> 'a t = fun op c -> Lwt.return @@ op c

    let ls : Path.t -> (Name.t * cursor) list t = fun path c ->
      Lwt.return @@ Op.ls_no_lwt path c

    let fold
        : 'acc
          -> Path.t
          -> ('acc -> Path.t -> cursor -> ([`Continue | `Exit | `Up ] * 'acc, Error.t) result Lwt.t)
          -> 'acc t
      = fun init path f c ->
        match Op.seek path c with
        | Error e -> Lwt.return @@ Error e
        | Ok (c, _) ->
            let rec loop acc c =
              Lwt.bind (f acc (Op.get_path c) c) @@ fun res ->
              match res with
              | Error e -> Lwt.return @@ Error e
              | Ok (`Exit, acc) -> Lwt.return @@ Ok (`Exit, acc)
              | Ok (`Up, acc) -> Lwt.return @@ Ok (`Continue, acc)
              | Ok (`Continue, acc) ->
                  match c with
                  | Z (File _, _) -> Lwt.return @@ Ok (`Continue, acc)
                  | Z (Dir m, trail) ->
                      let rec loop2 acc = function
                        | [] -> Lwt.return @@ Ok (`Continue, acc)
                        | (k,v)::kvs ->
                            Lwt.bind (loop acc (Z (v,(k,Map.remove k m)::trail))) @@ function
                            | Error e -> Lwt.return @@ Error e
                            | Ok (`Exit, acc) -> Lwt.return @@ Ok (`Exit, acc)
                            | Ok (`Up, acc) -> Lwt.return @@ Ok (`Up, acc)
                            | Ok (`Continue, acc) -> loop2 acc kvs
                      in
                      loop2 acc @@ Map.bindings m
            in
            Lwt.bind (loop init c) @@ fun res ->
            match res with
            | Error e -> Lwt.return (Error e)
            | Ok (_, acc) -> Lwt.return (Ok (c, acc))

    let fold'
      : ?depth:[< `Eq of int | `Ge of int | `Gt of int | `Le of int | `Lt of int ]
        -> 'acc
        -> Path.t
        -> (Path.t -> cursor -> 'acc -> ('acc, Error.t) result Lwt.t)
        -> 'acc t
      = fun ?depth init path0 f ->
        let check =
          match depth with
          | None -> fun _ -> true, true
          | Some (`Eq n) -> fun x -> x < n, x = n
          | Some (`Le n) -> fun x -> x < n, x <= n
          | Some (`Lt n) -> fun x -> x < n-1, x < n
          | Some (`Ge n) -> fun x -> true, x >= n
          | Some (`Gt n) -> fun x -> true, x > n
        in
        fold init path0 @@ fun acc path c ->
        let depth = Path.length path in
        let deeper, callf = check depth in
        Lwt.bind (if callf then f path c acc else Lwt.return (Ok acc)) @@ function
        | Error e -> Lwt.return @@ Error e
        | Ok acc ->
            let command = if deeper then `Continue else `Up in
            Lwt.return @@ Ok (command, acc)
  end

end

module WithSimulation
    (Name : NAME)
= struct
  module F = Make(Name)
  module S = Simulation(Name)

  module Path = F.Path

  type name = Name.t

  type cursor = F.cursor * S.cursor

  type raw_cursor = cursor

  type view = F.view * S.view

  type hash = F.hash

  let empty ctxt = F.empty ctxt, S.empty ctxt

  let make _ _ = assert false

  type 'a op_lwt = cursor -> (cursor * 'a, Error.t) result Lwt.t

  type error = F.error =
    | Is_file of string * Path.t
    | Is_directory of string * Path.t
    | No_such_file_or_directory of string * Path.t
    | File_or_directory_exists of string * Path.t
    | Path_decode_failure of Segment.t
    | Other of string * string

  type Error.t += FS_error of error

  let error_fs e = Error (FS_error e)

  let handle_conflict n (res, res') =
    match res, res' with
    | Ok _, Error e ->
        Format.eprintf "%s: F: Ok, S: Error %a@." n Error.pp e;
        assert false
    | Error e, Ok _ ->
        Format.eprintf "%s: F: Error %a, S: Ok@." n Error.pp e;
        assert false
    | Error e, Error _ -> Error e
    | _ -> assert false

  module Op = struct
    type 'a t = cursor -> (cursor * 'a, Error.t) result

    let fail e _ = error_fs e

    let get_raw_cursor c = c
    let get_real_cursor f = F.get_raw_cursor f
    let get_model_tree (Z (mt, _) : S.cursor) = mt

    let context (fc,_) = F.context fc

    let raw_cursor c = Ok (c,c)

    let path (c, c') =
      match F.Op.path c, S.Op.path c' with
      | Ok (c, p), Ok (c', p') when p = p' -> Ok ((c,c'), p)
      | Ok (_c, p), Ok (_c', p') ->
          Format.eprintf "path: F: %a, S: %a@." Path.pp p Path.pp p';
          assert false
      | res, res' -> handle_conflict "path" (res, res')

    let chdir_parent (c, c') =
      match F.Op.chdir_parent c, S.Op.chdir_parent c' with
      | Ok (c, ()), Ok (c', ()) -> Ok ((c,c'), ())
      | res -> handle_conflict "chdir_parent" res

    let chdir_root (c, c') =
      match F.Op.chdir_root c, S.Op.chdir_root c' with
      | Ok (c, ()), Ok (c', ()) -> Ok ((c,c'), ())
      | res -> handle_conflict "chdir_root" res

    let chdir ?dig path (c, c') =
      match F.Op.chdir ?dig path c, S.Op.chdir ?dig path c' with
      | Ok (c, ()), Ok (c', ()) -> Ok ((c,c'), ())
      | res -> handle_conflict "chdir" res

    let get segs (c, c') =
      match F.Op.get segs c, S.Op.get segs c' with
      | Ok (c, (c_, v)), Ok (c', (c'_, v')) ->
          (match v, v' with
           | Leaf (value, _, _), File value' when value = value' ->
               Ok ((c, c'), ((c_,c'_), (v, v')))
           | Bud _, Dir _ ->
               Ok ((c, c'), ((c_,c'_), (v, v'))) (* no deep check *)
           | _ -> assert false)
      | x -> handle_conflict "get" x

    let cat segs (c, c') =
      match F.Op.cat segs c, S.Op.cat segs c' with
      | Ok (c, v), Ok (c', v') ->
          assert (v = v');
          Ok ((c,c'),v)
      | x -> handle_conflict "cat" x

    let write segs0 v (c, c') =
      match
        F.Op.write segs0 v c,
        S.Op.write segs0 v c'
      with
      | Ok (c, ()), Ok (c', ()) ->
          Ok ((c,c'), ())
      | x -> handle_conflict "write" x

    let set segs0 (d,d') (c,c') =
      match
        F.Op.set segs0 d c,
        S.Op.set segs0 d' c'
      with
      | Ok (c, ()), Ok (c', ()) ->
          Ok ((c,c'), ())
      | x -> handle_conflict "set" x

    let copy from to_ (c,c') =
      match
        F.Op.copy from to_ c,
        S.Op.copy from to_ c'
      with
      | Ok (c, ()), Ok (c', ()) ->
          Ok ((c,c'), ())
      | x -> handle_conflict "copy" x

    let rm ?recursive ?ignore_error segs (c, c') =
      match
        F.Op.rm ?recursive ?ignore_error segs c,
        S.Op.rm ?recursive ?ignore_error segs c'
      with
      | Ok (c, b), Ok (c', b') ->
          assert (b = b');
          Ok ((c, c'), b)
      | x -> handle_conflict "rm" x

    let rmdir ?ignore_error segs (c, c') =
      match
        F.Op.rmdir ?ignore_error segs c,
        S.Op.rmdir ?ignore_error segs c'
      with
      | Ok (c, b), Ok (c', b') ->
          assert (b = b');
          Ok ((c, c'), b)
      | x -> handle_conflict "rm" x

    module Monad = Monad.Make1(struct
        type nonrec 'a t = 'a t

        let bind (aop : 'a t) (f : 'a -> 'b t) : 'b t = fun c ->
          match aop c with
          | Error e ->
              Error e
          | Ok (c, a) ->
              f a c

        let return a c = Ok (c, a)
      end)

    let do_then f (g : 'a t) = fun c -> f c; g c

    let run c op = op c
  end

  module Op_lwt = struct
    include Monad.Make1(struct
        type 'a t = cursor -> (cursor * 'a, Error.t) result Lwt.t

        let return a c = Lwt.return_ok (c, a)

        let bind (aop : 'a t) (f : 'a -> 'b t) : 'b t =
          fun c ->
          Lwt.bind (aop c) (function
              | Error _ as e -> Lwt.return e
              | Ok (c, a) -> f a c)
      end)

    let lift : 'a Op.t -> 'a t = fun op c -> Lwt.return @@ op c

    let ls segs0 (c, c') =
      Lwt.bind (F.Op_lwt.ls segs0 c) @@ fun res ->
      Lwt.bind (S.Op_lwt.ls segs0 c') @@ fun res' ->
      Lwt.return @@
      match res, res' with
      | Ok (c,kvs), Ok (c',kvs') ->
          let kvs = List.sort (fun (k,_v) (k',_v') -> compare k k') kvs in
          let kvs' = List.sort (fun (k,_v) (k',_v') -> compare k k') kvs' in
          (* using Name.t's polymorphic equality *)
          let ks = List.map fst kvs in
          let ks' = List.map fst kvs' in
          if not (Path.equal ks ks') then begin
            Format.eprintf "ls F: [%a] S: [%a]@." F.Path.pp ks F.Path.pp ks';
            assert false
          end;
          Ok ((c,c'), List.map2 (fun (k,v) (_k',v') -> (k, (v,v'))) kvs kvs')
      | x -> handle_conflict "ls" x

    let fold init path (f,f') : _ op_lwt = fun (c,c') ->
      Lwt.bind (F.Op_lwt.fold init path f c) @@ fun res ->
      Lwt.bind (S.Op_lwt.fold init path f' c') @@ fun res' ->
      Lwt.return @@
      match res, res' with
      | Ok (c,acc), Ok (c',_acc') -> Ok ((c,c'),acc)
      | x -> handle_conflict "fold" x

    let fold' ?depth init path (f,f') : _ op_lwt = fun (c,c') ->
      Lwt.bind (F.Op_lwt.fold' ?depth init path f c) @@ fun res ->
      Lwt.bind (S.Op_lwt.fold' ?depth init path f' c') @@ fun res' ->
      Lwt.return @@
      match res, res' with
      | Ok (c,acc), Ok (c',acc') ->
          (* generally impossible to check acc = acc' *)
          Ok ((c,c'),(acc, acc'))
      | x -> handle_conflict "fold'" x
  end

  let use_f f (c,c') =
    match f c with
    | Ok (c, res) -> Ok ((c,c'), res)
    | Error e -> Error e

  let write_top_cursor x = use_f F.write_top_cursor x

  let compute_hash x = use_f F.Op.compute_hash x

  let may_forget x = use_f F.Op.may_forget x

end