<commit_before>(*
 * Copyright (c) 2013-2014 <NAME> <<EMAIL>>
 *
 * 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 Lwt
open Core_kernel.Std

module Log = Log.Make(struct let section = "tree" end)

module type S = sig
  include IrminStore.RW with type key = IrminPath.t
  type internal_key
  val import:
    contents:(internal_key -> value option Lwt.t) ->
    node:(internal_key ->  internal_key IrminNode.t option Lwt.t) ->
    internal_key -> t Lwt.t
  val export:
    contents:(value -> internal_key Lwt.t) ->
    node:(internal_key IrminNode.t -> internal_key Lwt.t) ->
    t -> internal_key Lwt.t
end

module Make (Store: IrminContents.STORE) = struct

  module K = Store.Key
  module C = Store.Value

  type internal_key = Store.key

  module Contents = struct

    type contents_or_key =
      | Key of K.t
      | Contents of C.t

    type t = contents_or_key ref
    (* Same as [IrminContents.t] but can either be a raw contents or a
       key that will be fetched lazily. *)

    let create c =
      ref (Contents c)

    let export c =
      match !c with
      | Key k      -> k
      | Contents _ -> failwith "Contents.export"

    let key k =
      ref (Key k)

    let read ~contents t =
      match !t with
      | Contents c -> return (Some c)
      | Key k      ->
        contents k >>= function
        | None   -> return_none
        | Some c ->
          t := Contents c;
          return (Some c)

  end

  module Node = struct

    type node = {
      contents: Contents.t option;
      succ    : t String.Map.t;
    }

    and node_or_key  =
      | Key of K.t
      | Node of node

    and t = node_or_key ref
    (* Similir to [IrminNode.t] but using where all of the values can
       just be keys. *)

    let create' contents succ =
      Node { contents; succ }

    let create contents succ =
      ref (create' contents succ)

    let key k =
      ref (Key k)

    let empty () =
      create None String.Map.empty

    let is_empty n =
      match !n with
      | Key _  -> false
      | Node n -> n.contents = None && Map.is_empty n.succ

    let import n =
      let contents = match n.IrminNode.contents with
        | None   -> None
        | Some k -> Some (Contents.key k) in
      let succ = Map.map ~f:key n.IrminNode.succ in
      { contents; succ }

    let export n =
      match !n with
      | Key k  -> k
      | Node _ -> failwith "Node.export"

    let export_node n =
      let contents = match n.contents with
        | None   -> None
        | Some c -> Some (Contents.export c) in
      let succ = Map.map ~f:export n.succ in
      { IrminNode.contents; succ }

    let read ~node t =
      match !t with
      | Node n   -> return (Some n)
      | Key k    ->
        node k >>= function
        | None   -> return_none
        | Some n ->
          t := Node n;
          return (Some n)

    let contents ~node ~contents t =
     read node t >>= function
     | None   -> return_none
     | Some c ->
       match c.contents with
       | None   -> return_none
       | Some c -> Contents.read contents c

    let update_contents ~node t v =
      read node t >>= function
      | None   -> if v = None then return_unit else fail Not_found (* XXX ? *)
      | Some n ->
        let n = match v with
          | None   -> { n with contents = None }
          | Some c -> { n with contents = Some (Contents.create c) } in
        t := Node n;
        return_unit

    let update_succ ~node t succ =
      read node t >>= function
      | None   -> if Map.is_empty succ then return_unit else fail Not_found (* XXX ? *)
      | Some n ->
        t := Node { n with succ };
        return_unit

  end

  type t = {
    node    : K.t -> Node.node option Lwt.t;
    contents: K.t -> C.t option Lwt.t;
    view    : Node.t;
  }

  type key = IrminPath.t

  type value = C.t

  let create () =
    let node _ = return_none in
    let contents _ = return_none in
    let view = Node.empty () in
    return { node; contents; view }

  let mapo fn = function
    | None   -> return_none
    | Some x -> fn x >>= fun y -> return (Some y)

  let import ~contents ~node key =
    node key >>= function
    | None   -> fail Not_found
    | Some n ->
      let node k =
        node k >>= function
        | None   -> return_none
        | Some n -> return (Some (Node.import n)) in
      let view = Node.key key in
      return { node; contents; view }

  let export ~contents ~node t =
    let node n =
      node (Node.export_node n) in
    let todo = Stack.create () in
    let rec add_to_todo n =
      match !n with
      | Node.Key _  -> ()
      | Node.Node x ->
        (* 1. we push the current node job on the stack. *)
        Stack.push todo (fun () ->
            node x >>= fun k ->
            n := Node.Key k;
            return_unit
          );
        (* 2. we push the contents job on the stack. *)
        Stack.push todo (fun () ->
            match x.Node.contents with<commit_msg>Add some debug statements in IrminView<commit_after>(*
 * Copyright (c) 2013-2014 <NAME> <<EMAIL>>
 *
 * 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 Lwt
open Core_kernel.Std

module Log = Log.Make(struct let section = "view" end)

module type S = sig
  include IrminStore.RW with type key = IrminPath.t
  type internal_key
  val import:
    contents:(internal_key -> value option Lwt.t) ->
    node:(internal_key ->  internal_key IrminNode.t option Lwt.t) ->
    internal_key -> t Lwt.t
  val export:
    contents:(value -> internal_key Lwt.t) ->
    node:(internal_key IrminNode.t -> internal_key Lwt.t) ->
    t -> internal_key Lwt.t
end

module Make (Store: IrminContents.STORE) = struct

  module K = Store.Key
  module C = Store.Value

  type internal_key = Store.key

  module Contents = struct

    type contents_or_key =
      | Key of K.t
      | Contents of C.t

    type t = contents_or_key ref
    (* Same as [IrminContents.t] but can either be a raw contents or a
       key that will be fetched lazily. *)

    let create c =
      ref (Contents c)

    let export c =
      match !c with
      | Key k      -> k
      | Contents _ -> failwith "Contents.export"

    let key k =
      ref (Key k)

    let read ~contents t =
      match !t with
      | Contents c -> return (Some c)
      | Key k      ->
        contents k >>= function
        | None   -> return_none
        | Some c ->
          t := Contents c;
          return (Some c)

  end

  module Node = struct

    type node = {
      contents: Contents.t option;
      succ    : t String.Map.t;
    }

    and node_or_key  =
      | Key of K.t
      | Node of node

    and t = node_or_key ref
    (* Similir to [IrminNode.t] but using where all of the values can
       just be keys. *)

    let create' contents succ =
      Node { contents; succ }

    let create contents succ =
      ref (create' contents succ)

    let key k =
      ref (Key k)

    let empty () =
      create None String.Map.empty

    let is_empty n =
      match !n with
      | Key _  -> false
      | Node n -> n.contents = None && Map.is_empty n.succ

    let import n =
      let contents = match n.IrminNode.contents with
        | None   -> None
        | Some k -> Some (Contents.key k) in
      let succ = Map.map ~f:key n.IrminNode.succ in
      { contents; succ }

    let export n =
      match !n with
      | Key k  -> k
      | Node _ -> failwith "Node.export"

    let export_node n =
      let contents = match n.contents with
        | None   -> None
        | Some c -> Some (Contents.export c) in
      let succ = Map.map ~f:export n.succ in
      { IrminNode.contents; succ }

    let read ~node t =
      match !t with
      | Node n   -> return (Some n)
      | Key k    ->
        node k >>= function
        | None   -> return_none
        | Some n ->
          t := Node n;
          return (Some n)

    let contents ~node ~contents t =
     read node t >>= function
     | None   -> return_none
     | Some c ->
       match c.contents with
       | None   -> return_none
       | Some c -> Contents.read contents c

    let update_contents ~node t v =
      read node t >>= function
      | None   -> if v = None then return_unit else fail Not_found (* XXX ? *)
      | Some n ->
        let n = match v with
          | None   -> { n with contents = None }
          | Some c -> { n with contents = Some (Contents.create c) } in
        t := Node n;
        return_unit

    let update_succ ~node t succ =
      read node t >>= function
      | None   -> if Map.is_empty succ then return_unit else fail Not_found (* XXX ? *)
      | Some n ->
        t := Node { n with succ };
        return_unit

  end

  type t = {
    node    : K.t -> Node.node option Lwt.t;
    contents: K.t -> C.t option Lwt.t;
    view    : Node.t;
  }

  type key = IrminPath.t

  type value = C.t

  let create () =
    Log.debugf "create";
    let node _ = return_none in
    let contents _ = return_none in
    let view = Node.empty () in
    return { node; contents; view }

  let mapo fn = function
    | None   -> return_none
    | Some x -> fn x >>= fun y -> return (Some y)

  let import ~contents ~node key =
    Log.debugf "import %s" (K.to_string key);
    node key >>= function
    | None   -> fail Not_found
    | Some n ->
      let node k =
        node k >>= function
        | None   -> return_none
        | Some n -> return (Some (Node.import n)) in
      let view = Node.key key in
      return { node; contents; view }

  let export ~contents ~node t =
    Log.debugf "export";
    let node n =
      node (Node.export_node n) in
    let todo = Stack.create () in
    let rec add_to_todo n =
      match !n with
      | Node.Key _  -> ()
      | Node.Node x ->
        (* 1. we push the current node job on the stack. *)
        Stack.push todo (fun () ->
            node x >>= fun k ->
            n := Node.Key k;
            return_unit
          );
        (* 2. we push the contents job on the stack. *)
        Stack.push todo (fun () ->
            match x.Node.contents with
{'fraction_non_alphanumeric': 0.09324787075248046, 'fraction_numerical': 0.0017560804284836246, 'mean_word_length': 1.861090178347149, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 149, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '314752', 'n_tokens_mistral': 3563, 'n_tokens_neox': 3427, 'n_words': 1367}