Cause: debugging experiment, tracking why values exist and actions were performed

.header

@@ -1,5 +1,5 @@
 (*
-copyright (c) 2013, simon cruanes
+copyright (c) 2013-2014, simon cruanes
 all rights reserved.
 
 redistribution and use in source and binary forms, with or without

_oasis

@@ -41,7 +41,7 @@ Library "containers"
                     UnionFind, SmallSet, Leftistheap, AbsSet, CSM, MultiMap,
                     ActionMan, BV, QCheck, BencodeOnDisk, Show, TTree,
                     HGraph, Automaton, Conv, Levenshtein, Bidir, Iteratee,
-                    Ty, Tell, BencodeStreaming, RatTerm
+                    Ty, Tell, BencodeStream, RatTerm, Cause
   BuildDepends:     unix
 
 Library "containers_thread"

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: d2a3ad58b5c7dfc3db2e09453554349c)
+# DO NOT EDIT (digest: a253a3102af478e2c2a6c4a7d330a848)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -58,7 +58,10 @@
 "bidir.cmx": for-pack(Containers)
 "iteratee.cmx": for-pack(Containers)
 "ty.cmx": for-pack(Containers)
+"tell.cmx": for-pack(Containers)
+"bencodeStream.cmx": for-pack(Containers)
 "ratTerm.cmx": for-pack(Containers)
+"cause.cmx": for-pack(Containers)
 # Library containers_thread
 "threads/containers_thread.cmxs": use_containers_thread
 <threads/*.ml{,i}>: package(threads)

cause.ml

@@ -0,0 +1,168 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 Causal Graph} for Debugging *)
+
+(** {2 Basic Causal Description} *)
+
+type t = {
+  id : int;
+  descr : string;
+  attrs : string list;
+  mutable within : t list;
+  mutable after : t list;
+}
+
+type cause = t
+
+let _count = ref 0
+
+let make ?(attrs=[]) ?(within=[]) ?(after=[]) descr =
+  let id = !_count in
+  incr _count;
+  { id; descr; attrs; within; after; }
+
+let root = make ~within:[] ~after:[] "root cause"
+
+let make_b ?attrs ?within ?after fmt =
+  let buf = Buffer.create 24 in
+  Printf.kbprintf
+    (fun buf -> make ?attrs ?within ?after (Buffer.contents buf))
+    buf fmt
+
+let add_within a b = a.within <- b :: a.within
+let add_after a b = a.after <- b :: a.after
+
+let id c = c.id
+
+let level c = assert false  (* TODO *)
+
+let pp buf c =
+  let rec pp_id_list buf l = match l with
+    | [] -> ()
+    | [x] -> Printf.bprintf buf "%d" x.id
+    | x::l' -> Printf.bprintf buf "%d, " x.id; pp_id_list buf l'
+  in
+  Printf.bprintf buf "cause_%d{%s, within{%a}, after{%a}}" c.id
+    c.descr pp_id_list c.within pp_id_list c.after
+
+let fmt fmt c =
+  let buf = Buffer.create 15 in
+  pp buf c;
+  Format.pp_print_string fmt (Buffer.contents buf)
+
+(** {2 Encoding to/from B-Encode} *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+module Bencode = struct
+  type token =
+    [ `I of int
+    | `S of string
+    | `BeginDict
+    | `BeginList
+    | `End
+    ]
+
+  let to_seq c k =
+    k `BeginDict;
+    k (`S "after");
+    k `BeginList;
+    List.iter (fun c' -> k (`I c'.id)) c.after;
+    k `End;
+    k (`S "attrs");
+    k `BeginList;
+    List.iter (fun s -> k (`S s)) c.attrs;
+    k `End;
+    k (`S "descr");
+    k (`S c.descr);
+    k (`S "id");
+    k (`I c.id);
+    k (`S "within");
+    k `BeginList;
+    List.iter (fun c' -> k (`I c'.id)) c.within;
+    k `End;
+    k `End
+
+  module ITbl = Hashtbl.Make(struct
+    type t = int
+    let equal i j = i=j
+    let hash i = i land max_int
+  end)
+
+  module Sink = struct
+    type t = {
+      send : token -> unit;
+      ids : unit ITbl.t; (* printed IDs *)
+    }
+
+    let make send = { send; ids = ITbl.create 32; }
+
+    let mem sink id = ITbl.mem sink.ids id
+
+    let print sink c =
+      let s = Stack.create () in
+      Stack.push (`Enter c) s;
+      (* DFS in postfix order *)
+      while not (Stack.is_empty s) do
+        match Stack.pop s with
+        | `Enter c when mem sink c.id -> ()  (* already done *)
+        | `Enter c ->
+            ITbl.add sink.ids c.id ();
+            (* explore sub-causes *)
+            List.iter (fun c' -> Stack.push (`Enter c') s) c.within;
+            List.iter (fun c' -> Stack.push (`Enter c') s) c.after;
+            Stack.push (`Exit c) s;
+        | `Exit c ->
+            (* print the cause *)
+            to_seq c sink.send
+      done
+  end
+
+  module Source = struct
+    type t = {
+      tbl : cause ITbl.t;
+      mutable roots : cause list;
+    }
+
+    let make seq =
+      let tbl = ITbl.create 128 in
+      let _roots = ref [] in
+      seq
+        (function
+        | _ -> assert false (* TODO parse back *)
+        );
+        { tbl; roots= !_roots; }
+
+    let roots src k = List.iter k src.roots
+
+    let by_id_exn src id = ITbl.find src.tbl id
+
+    let by_id src id =
+      try Some (by_id_exn src id)
+      with Not_found -> None
+  end
+end

cause.mli

@@ -0,0 +1,125 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 Causal Graph} for Debugging
+As often, for unique name generation reasons, this module is not thread
+safe (several causes may have the same name otherwise, which can break
+serialization).
+
+Causal loops should be avoided. *)
+
+(** {2 Basic Causal Description} *)
+
+type t
+type cause = t
+
+val root : t
+  (** Root cause (the start of the program?) *)
+
+val make : ?attrs:string list -> ?within:t list -> ?after:t list ->
+            string -> t
+  (** New cause for some object, that depends on an informal description
+      (the string parameter), some previous objects (the [after] list),
+      and some more global context (ongoing task? see [within]).
+
+      @param attrs attributes that describe the cause further. *)
+
+val make_b : ?attrs:string list -> ?within:t list -> ?after:t list ->
+             ('a, Buffer.t, unit, t) format4 -> 'a
+  (** Same as {!make}, but allows to use Buffer printers to build the
+      description. *)
+
+val add_within : t -> t -> unit
+  (** [within a b] specifies that [a] occurs within the more general context
+      of [b]. *)
+
+val add_after : t -> t -> unit
+  (** [after a b] specifies that [a] is (partially) caused by [b], and occurs
+      afterwards. *)
+
+val id : t -> int
+  (** Unique ID of the cause. Can be used for equality, hashing, etc. *)
+
+val level : t -> int
+  (** Depth-level of the cause. It is determined from the [within] and
+      [after] relations of the cause with other causes. *)
+
+val pp : Buffer.t -> t -> unit
+  (** print a single step *)
+
+val fmt : Format.formatter -> t -> unit
+
+(** {2 Encoding to/from B-Encode}
+This can be used for serializing a cause (set) and re-examine them
+later. It assumes a streaming API because cause graphs can become
+huge quickly. *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+module Bencode : sig
+  type token =
+    [ `I of int
+    | `S of string
+    | `BeginDict
+    | `BeginList
+    | `End
+    ]
+
+  val to_seq : cause -> token sequence
+    (** token representation of a single cause *)
+
+  module Sink : sig
+    type t
+
+    val make : (token -> unit) -> t
+    (** Build a sink from some way of printing B-encode values out *)
+
+    val mem : t -> int -> bool
+    (** Is the given [id] already printed into the sink? *)
+
+    val print : t -> cause -> unit
+    (** Print the given cause (if not already printed). *)
+  end
+
+  module Source : sig
+    type t
+
+    val make : token sequence -> t
+    (** Build a source of causal graph from some sequence of B-encode
+        values. The whole graph will be read immediately, but the sequence
+        is iterated on only once. *)
+
+    val roots : t -> cause sequence
+    (** Causes that have no parent (no [within] field) *)
+
+    val by_id : t -> int -> cause option
+    (** Retrieve a cause by its unique ID, if present *)
+
+    val by_id_exn : t -> int -> cause
+    (** Same as {!by_id}, but unsafe.
+        @raise Not_found if the ID is not present. *)
+  end
+end

containers.mlpack

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: cb1aefd35a4e870e47f7c27f77a176c4)
+# DO NOT EDIT (digest: 9824af535a520376fdb1b1ac58c878c9)
 Cache
 Deque
 Gen
@@ -43,5 +43,8 @@ Levenshtein
 Bidir
 Iteratee
 Ty
+Tell
+BencodeStream
 RatTerm
+Cause
 # OASIS_STOP

containers.odocl

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: cb1aefd35a4e870e47f7c27f77a176c4)
+# DO NOT EDIT (digest: 9824af535a520376fdb1b1ac58c878c9)
 Cache
 Deque
 Gen
@@ -43,5 +43,8 @@ Levenshtein
 Bidir
 Iteratee
 Ty
+Tell
+BencodeStream
 RatTerm
+Cause
 # OASIS_STOP

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.3.0 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 3eddef054795635a1438f2701ea9b0ca) *)
+(* DO NOT EDIT (digest: d81d54173b4f70a25124ba24fef82bc2) *)
 (*
    Regenerated by OASIS v0.4.4
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -7002,7 +7002,10 @@ let setup_t =
                            "Bidir";
                            "Iteratee";
                            "Ty";
-                           "RatTerm"
+                           "Tell";
+                           "BencodeStream";
+                           "RatTerm";
+                           "Cause"
                         ];
                       lib_pack = true;
                       lib_internal_modules = [];
@@ -7389,7 +7392,7 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.4";
-     oasis_digest = Some "p>\164\222\"C\130\166G\158\178\173\130\241\148'";
+     oasis_digest = Some "\242\031\132\250-\201+\tJ\171/\017\158\211\194\168";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
@@ -7397,6 +7400,6 @@ let setup_t =
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7401 "setup.ml"
+# 7404 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;