diff --git a/.header b/.header index 1c9ac57c..71e61012 100644 --- a/.header +++ b/.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 diff --git a/_oasis b/_oasis index 79d8af3a..c8dcef11 100644 --- a/_oasis +++ b/_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" diff --git a/_tags b/_tags index 6791896c..b8d7a0a7 100644 --- a/_tags +++ b/_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 : package(threads) diff --git a/cause.ml b/cause.ml new file mode 100644 index 00000000..6452f766 --- /dev/null +++ b/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 diff --git a/cause.mli b/cause.mli new file mode 100644 index 00000000..ced3d9a1 --- /dev/null +++ b/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 diff --git a/containers.mlpack b/containers.mlpack index 3ed2e230..3790fe30 100644 --- a/containers.mlpack +++ b/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 diff --git a/containers.odocl b/containers.odocl index 3ed2e230..3790fe30 100644 --- a/containers.odocl +++ b/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 diff --git a/setup.ml b/setup.ml index e6ae6fe5..b2614038 100644 --- a/setup.ml +++ b/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 ();;