Source file debug.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019,2020 DaiLambda, Inc. <contact@dailambda.jp>            *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Utils
open Result_lwt.Infix

open Cursor
open Node_type

let segment seg =
  let s = Segment.to_string seg in
  if String.length s > 16 then
    String.sub s 0 8 ^ ".." ^ String.sub s (String.length s - 8) 8
  else s

let simple_string_of_node : node -> string = fun node ->
  (* pretty prints a tree to a string *)
  let string_of_node n =
    match Node_type.index n with
    | None -> "no index"
    | Some i -> Int64.to_string @@ Index.to_int64 i
  in
  match node with
  | Disk (index, _) -> Format.asprintf "Disk %a" Index.pp index
  | Hash h -> Format.asprintf "Hash %a" Hash.pp h
  | View (Leaf (value, Indexed i, Hashed hp)) ->
      Format.asprintf "Leaf %S (%a, %s)\n" (Value.to_string value)
        Index.pp i (Hash.Prefix.to_hex_string hp)
  | View (Leaf (value, _, _)) ->
      Printf.sprintf "Leaf %S\n" (Value.to_string value)
  | View (Bud  (node , _, _)) ->
      let recursive =
        match node with
        | Some node -> string_of_node node
        | None     ->  "Empty"
      in
      Printf.sprintf "Bud: %s" recursive
  | View (Internal (left, right, _, _)) ->
      Printf.sprintf "Internal: %s%s"
        (string_of_node left)
        (string_of_node right)
  | View (Extender (seg, node, _, _)) ->
      Printf.sprintf "[%s]- %s"
        (segment seg)
        (string_of_node node)

let rec string_of_node : node -> int -> string = fun node indent ->
  (* pretty prints a tree to a string *)
  let indent_string = String.concat "" (List.init indent (fun _ -> "  ")) in
  match node with
  | Disk (index, _) -> Format.asprintf "%sDisk %a" indent_string Index.pp index
  | Hash h -> Format.asprintf "%sHash %a" indent_string Hash.pp h
  | View (Leaf (value, Indexed i, Hashed hp)) ->
      Format.asprintf "%sLeaf %S (%a, %s)\n" indent_string (Value.to_string value)
        Index.pp i (Hash.Prefix.to_hex_string hp)
  | View (Leaf (value, _, _)) ->
      Printf.sprintf "%sLeaf %S\n" indent_string (Value.to_string value)
  | View (Bud  (node , _, _)) ->
      let recursive =
        match node with
        | Some node -> string_of_node node (indent + 1)
        | None     ->  "Empty"
      in
      Printf.sprintf "%sBud:\n%s" indent_string recursive
  | View (Internal (left, right, _, Hashed hp)) ->
      Format.asprintf "%sInternal: %a\n%s%s" indent_string
        Hash.Prefix.pp hp
        (string_of_node left (indent + 1))
        (string_of_node right (indent + 1))
  | View (Internal (left, right, _, Not_Hashed)) ->
      Printf.sprintf "%sInternal: no hash\n%s%s" indent_string
        (string_of_node left (indent + 1))
        (string_of_node right (indent + 1))
  | View (Extender (seg, node, _, _)) ->
      Printf.sprintf "%s[%s]- %s" indent_string (segment seg)
        (string_of_node node (indent + 1))

module Dot = struct
  (* Graphviz's dot file format *)

  let link ?label n1 n2 =
    match label with
    | None -> Printf.sprintf "%s -> %s;" n1 n2
    | Some l -> Printf.sprintf "%s -> %s [label=\"%s\"];" n1 n2 l

  let linkX ?label n1 n2 =
    match label with
    | None -> Printf.sprintf "%s -> %s [color=red];" n1 n2
    | Some l -> Printf.sprintf "%s -> %s [label=\"%s\", color=red];" n1 n2 l

  let indexed = function
    | Indexed i -> Int64.to_string @@ Index.to_int64 i
    | Not_Indexed -> "n/i"

  let modified = function
    | Modified -> "*"
    | Unmodified (ir, _) -> indexed ir

  let disk n = Printf.sprintf "%s [shape=box];" n
  let hash n = Printf.sprintf "%s [shape=box];" n
  let leaf n value ir = Printf.sprintf "%s [label=%S];"
      n
      (let s = Value.to_string value in
       (if String.length s > 9 then String.sub s 0 8 ^ ".." else s) ^ ir)
  let bud n ir = Printf.sprintf "%s [shape=diamond, label=\"%s\"];" n ir
  let internal n ir = Printf.sprintf "%s [shape=circle, label=\"%s\"];" n ir
  let extender = internal

  let of_node_aux cntr root =
    let rec aux : int -> node -> (string * string list * int) = fun cntr -> function
      | Disk (index, _) ->
          let n = Format.asprintf "Disk%a" Index.pp index in
          (n, [disk n], cntr)
      | Hash h ->
          let n = Format.asprintf "Hash%a" Hash.pp h in
          (n, [hash n], cntr)
      | View (Leaf (value, ir, _)) ->
          let n = Printf.sprintf "Leaf%d\n" cntr in
          (n, [leaf n value (indexed ir)], cntr+1)
      | View (Bud  (Some node , ir, _)) ->
          let n', s, cntr = aux cntr node in
          let n = Printf.sprintf "Bud%d" cntr in
          (n,
           [bud n (indexed ir);
            link n n'
           ] @ s,
           cntr + 1)
      | View (Bud  (None , ir, _)) ->
          let n = Printf.sprintf "Bud%d" cntr in
          (n,
           [bud n (indexed ir)],
           cntr + 1)
      | View (Internal (left, right, ir, _)) ->
          let ln, ls, cntr = aux cntr left in
          let rn, rs, cntr = aux cntr right in
          let n = Printf.sprintf "Internal%d" cntr in
          (n,
           [ internal n (indexed ir);
             link n ln ~label:"L";
             link n rn ~label:"R" ]
           @ ls @ rs,
           cntr + 1)
      | View (Extender (seg, node, ir, _)) ->
          let n', s, cntr = aux cntr node in
          let n = Printf.sprintf "Extender%d" cntr in
          (n,
           extender n (indexed ir)
           :: linkX n n' ~label:(segment seg)
           :: s,
           cntr + 1)
    in
    aux cntr root

  let rec of_trail dst cntr = function
    | Top -> ([], cntr)
    | Left (trail, r, mr) ->
        let n = Printf.sprintf "Internal%d" cntr in
        let cntr = cntr + 1 in
        let r, ss, cntr = of_node_aux cntr r in
        let (ss', cntr) = of_trail n cntr trail in
        ([ internal n (modified mr);
           link n dst ~label:"L";
           link n r ~label:"R" ]
         @ ss @ ss',
         cntr)
    | Right (l, trail, mr) ->
        let n = Printf.sprintf "Internal%d" cntr in
        let cntr = cntr + 1 in
        let l, ss, cntr = of_node_aux cntr l in
        let (ss', cntr) = of_trail n cntr trail in
        ([ internal n (modified mr);
           link n l ~label:"L";
           link n dst ~label:"R" ]
         @ ss @ ss',
         cntr)
    | Budded (trail, mr) ->
        let n = Printf.sprintf "Bud%d" cntr in
        let cntr = cntr + 1 in
        let (ss, cntr) = of_trail n cntr trail in
        ([ bud n (modified mr);
           link n dst ]
         @ ss,
         cntr)
    | Extended (trail, seg, mr) ->
        let n = Printf.sprintf "Extender%d" cntr in
        let cntr = cntr + 1 in
        let (ss, cntr) = of_trail n cntr trail in
        ([ extender n (modified mr);
           link n dst ~label:(segment seg) ]
         @ ss,
         cntr)

  let make_digraph ss = "digraph G {\n" ^ String.concat "\n" ss ^ "\n}\n"

  let of_node root =
    let (_name, ss, _cntr) = of_node_aux 0 root in
    make_digraph ss

  let of_cursor (Cursor (trail, node, _, _)) =
    let (n, ss, cntr) = of_node_aux 0 node in
    let ss', _ = of_trail n cntr trail in
    let s = Printf.sprintf "cursor [shape=point, label=\"\"]; cursor -> %s [style=bold];" n in
    make_digraph (s :: ss @ ss')
end

let dot_of_node = Dot.of_node
let dot_of_cursor = Dot.of_cursor

let () = Cursor.dot_of_cursor_ref := dot_of_cursor

(* Bud -> Leaf and Bud -> Bud are invalid, but not excluded by the GADT *)
let validate_node context (node : node) =
  let rec aux : node -> (unit, string) Result.t =
    fun node ->
      let indexed : view -> bool = function
        | Internal (_, _, Indexed _, _) -> true
        | Bud (_, Indexed _, _) -> true
        | Leaf (_, Indexed _, _) -> true
        | Extender (_, _, Indexed _, _) -> true
        | _ -> false
      in
      let hashed_is_transitive : view -> bool = function
        | Internal (_, _, _, Hashed _) -> true
        | Bud (_, _, Hashed _) -> true
        | Leaf (_, _, Hashed _) -> true
        | Extender (_, _, _, Hashed _) -> true

        (* Hashes are on disk *)
        | Internal (_, _, Indexed _, _) -> true
        | Bud (_, Indexed _, _) -> true
        | Leaf (_, Indexed _, _) -> true
        | Extender (_, _, Indexed _, _) -> true
        | _ -> false
      in
      match node with
      | Disk  (i, wit) ->
          aux @@ View (Node_storage.read_node context i wit)
      | Hash _ -> Ok ()
      | View v ->
          match v with
          | Leaf _ -> Ok ()
          | Bud (None, _, _) -> Ok ()
          | Bud (Some child, ir, hit) ->
              begin
                aux child >>? fun () ->
                match child with
                | Disk _ -> Ok () (* we now allow Disk under Bud *)
                | Hash _ -> Ok ()
                | View (Bud _) -> Error "Bud cannot carry Bud"
                | View (Leaf _) -> Error "Bud cannot carry Leaf"
                | View v' ->
                    (match ir, indexed v' with
                     | _, true -> Ok ()
                     | Not_Indexed, _ -> Ok ()
                     | _ -> Error "Bud: Strange indexed") >>? fun () ->
                    (match hit, hashed_is_transitive v' with
                     | _, true -> Ok ()
                     | Not_Hashed, _ -> Ok ()
                     | _ -> Error "Bud: Strange hashed_is_transitive")
                end
          | Internal (l, r, ir, hit) ->
              begin
                aux l >>? fun () ->
                aux r >>? fun () ->
                let indexed_or_hash = function
                  | Disk _ -> true
                  | Hash _ -> true
                  | View v -> indexed v
                in
                (match ir, indexed_or_hash l, indexed_or_hash r with
                 | _, true, true -> Ok ()
                 | Not_Indexed, _, _ -> Ok ()
                 | Indexed _, _, _ -> Error "Internal: Strange indexed") >>? fun () ->
                let hashed_is_transitive_or_hash = function
                  | Disk _ -> true
                  | Hash _ -> true
                  | View v -> hashed_is_transitive v
                in
                (match hit, hashed_is_transitive_or_hash l, hashed_is_transitive_or_hash r with
                 | _, true, true -> Ok ()
                 | Not_Hashed, _, _ -> Ok ()
                 | _ -> Error "Internal: Strange hashed_is_transitive")
              end
          | Extender (seg, n, ir, hit) ->
              aux n >>? fun () ->
              match n with
              | Disk (_, Not_Extender) -> Ok ()
              | Disk _ -> Error "Extender cannot carry a Disk not with Not_Extender"
              | Hash (_, s) when s <> "" -> Error "Extender cannot carry Hash with a postfix"
              | View (Extender _) -> Error "Extender cannot carry Extender"
              | Hash _ ->
                  if Segment.length seg > Segment.max_length then
                    Error "segment too long"
                  else
                    Ok ()
              | View v' ->
                  if Segment.length seg > Segment.max_length then
                    Error "segment too long"
                  else
                    (match ir, indexed v' with
                     | _, true -> Ok ()
                     | Not_Indexed, _ -> Ok ()
                     | _ -> Error "Extender: Strange hashed_is_transitive") >>? fun () ->
                    (match hit, hashed_is_transitive v' with
                     | _, true -> Ok ()
                     | Not_Hashed, _ -> Ok ()
                     | _ -> Error "Extender: Strange hashed_is_transitive")
  in
  aux node >>? fun () ->
  match node with
  | Hash (_, s) when s <> "" -> Error "Root cannot be Hash with a postfix"
  | Hash _ -> Ok ()
  | Disk _ -> Ok ()
  | View (Bud _) -> Ok ()
  | _ -> Error "Tree must start with a Bud"

let save_cursor_to_dot name c = to_file ~file:name @@ dot_of_cursor c
let save_node_to_dot name n = to_file ~file:name @@ dot_of_node n