type t = string list

let this = []
let ( @/ ) x y = x :: y
let of_list segments = segments
let to_list path = path

let to_string path =
  path
  |> List.map (fun x ->
      BatString.nreplace ~str:(BatString.nreplace ~str:x ~sub:"^" ~by:"^^") ~sub:"\\" ~by:"^\\" )
  |> BatIO.to_string (BatList.print ~first:"\\" ~last:"" ~sep:"\\" BatString.print)

module Error = struct
  open Concepts.Condition

  let path_not_found path =
    condition "path-not-found" "A given path was not found under the specified object"
      ("path" |=| Concepts.Value.String (to_string path))

  let overlapping_change path =
    condition "overlapping-change"
      "A batch of changes both replaced an object and changed inside it"
      ("path" |=| Concepts.Value.String (to_string path))
end

let walking ?missing f g handle path =
  let rec walk handle = function
    | [] -> g handle
    | x :: xs -> (
        let open Utilities.Result in
        let open Protocols in
        let* dir =
          Handle.require Directory.from handle
          |> Result.map_error
               Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x))
        in
        let* elem = Directory.find dir x in
        match elem with
        | None -> (
          match missing with Some m -> m () | None -> Error (Error.path_not_found path) )
        | Some elem -> f x handle (fun () -> walk elem xs) )
  in
  walk handle path
  |> Result.map_error
       Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))

(* Handles we find in the middle of a walk get released once we're
   done with them, but never the caller's root.  If you leak one and
   its refcount never drops, nothing under that path gets collected,
   and an exclusive object, like a session, stays locked forever. *)
let releasing root handle f =
  Fun.protect ~finally:(fun () -> if handle != root then Protocols.Handle.release handle) f

let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path

let find handle path =
  walking
    ~missing:(fun () -> Ok None)
    (fun _ parent -> releasing handle parent)
    (fun h -> Ok (Some h))
    handle path

let update handle path key reference value =
  let open Utilities.Result in
  let open Protocols in
  let* target = lookup handle path in
  releasing handle target (fun () ->
      let* registry = Handle.require Registry.from target in
      Registry.update registry key reference value )

(* The changes at this object, and those beneath each child they reach. *)
let split changes =
  let here, below = List.partition (fun (path, _, _) -> path = []) changes in
  let segments =
    List.fold_left
      (fun segments (path, _, _) ->
        let x = List.hd path in
        if List.mem x segments then segments else segments @ [x] )
      [] below
  in
  let beneath x =
    List.filter_map
      (fun (path, key, value) ->
        match path with y :: rest when y = x -> Some (rest, key, value) | _ -> None )
      below
  in
  here, List.map (fun x -> x, beneath x) segments

(* What is not there yet is handed over as a directory of what the
   changes put in it, for its parent to store. *)
let rec fresh changes =
  let here, children = split changes in
  Prototype.(
    mixture
      [ Directory.of_properties
          ( List.filter_map (fun (_, key, value) -> Option.map (fun v -> key, v) value) here
          @ List.map (fun (x, beneath) -> x, fresh beneath) children ) ] )

let binds changes = List.exists (fun (_, _, value) -> Option.is_some value) changes

(* Changes under the same name are applied to the child together, so
   every object on the way is derived once however many changes reach
   it: a batch of changes to a branch is one successor state. *)
let assoc_all handle changes =
  let open Utilities.Result in
  let open Protocols in
  let assoc_on node (key, value) =
    let* a = Handle.require Associative.from node in
    let* a' = Associative.update a key value in
    Ok (Handle.from a')
  in
  let rec apply prefix node changes =
    let here, below = split changes in
    let segments = List.map fst below in
    match List.find_opt (fun (_, key, _) -> List.mem key segments) here with
    | Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key]))
    | None ->
        let* children =
          List.map
            (fun (x, beneath) ->
              let* dir = Handle.require Directory.from node in
              let* found = Directory.find dir x in
              match found with
              | None when binds beneath -> Ok [x, Some (fresh beneath)]
              | None -> Ok []
              | Some child ->
                  releasing handle child (fun () -> apply (prefix @ [x]) child beneath)
                  |> Result.map (fun child' -> [x, Some child']) )
            below
          |> Utilities.List.sequence
          |> Result.map List.concat
        in
        (* each step derives from the last; only the steps in between are
           ours to release *)
        List.fold_left
          (fun current change ->
            let* current = current in
            let* next = assoc_on current change in
            if current != node then Handle.release current;
            Ok next )
          (Ok node)
          (children @ List.map (fun (_, key, value) -> key, value) here)
  in
  apply [] handle changes

let assoc handle path key value = assoc_all handle [path, key, value]

let diff a b =
  let open Utilities.Result in
  let open Protocols in
  let address h = Option.map Addressable.address (Addressable.from h) in
  let same x y =
    match address x, address y with
    | Some p, Some q -> Concepts.Hash.hash_equals p q
    | _ -> Handle.equal x y
  in
  let names h =
    let* dir = Handle.require Directory.from h in
    let* names = Directory.list dir in
    Ok (BatFingerTree.to_list names)
  in
  let find h name =
    let* dir = Handle.require Directory.from h in
    Directory.find dir name
  in
  let rec walk prefix a b =
    let* left = names a in
    let* right = names b in
    List.sort_uniq String.compare (left @ right)
    |> List.map (fun name ->
        let path = prefix @ [name] in
        let* x = find a name in
        let* y = find b name in
        Fun.protect
          ~finally:(fun () -> List.iter Handle.release (Option.to_list x @ Option.to_list y))
          (fun () ->
            match x, y with
            | None, None -> Ok []
            | Some x, Some y when same x y -> Ok []
            | Some x, Some y when Directory.from x <> None && Directory.from y <> None ->
                let* below = walk path x y in
                Ok (if below = [] then [path] else below)
            | _ -> Ok [path] ) )
    |> Utilities.List.sequence
    |> Result.map List.concat
  in
  walk [] a b