ocamlbricks-0.90+bzr456.orig/0000755000175000017500000000000013175721006014724 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/README0000644000175000017500000000162313175721005015605 0ustar lucaslucasThis file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2008 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . OCamlBricks is a reusable library of generally useful OCaml functions and classes, with some very heterogeneous components. Please see the OCamlDoc documentation for details. ocamlbricks-0.90+bzr456.orig/configure0000644000175000017500000000222513175721005016630 0ustar lucaslucas#!/bin/sh # This file is part of our build system for OCaml projects # Copyright (C) 2008 Luca Saiu # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # To do: this should be copied to buildsystem/ echo "Sorry, there is no automatic configuration system, as of now." echo if [ -e etc ]; then echo "Now please edit the \"CONFIGME\" file and the files in etc/, using" echo "your favorite text editor." else echo "Now please edit the \"CONFIGME\" file, using your favorite text editor." fi # Exit with failure: it should be evident that the configuration is not # automatic: exit -1 ocamlbricks-0.90+bzr456.orig/ocamlbricks.mllib0000644000175000017500000000265613175721005020246 0ustar lucaslucas# This file is part of our reusable OCaml BRICKS library # Copyright (C) 2008 Luca Saiu # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # This is simply a list of the OCaml modules (*not* filenames) to be included # in the library: Argv ArrayExtra Bit Cache Cloakroom Configuration_files Container Cortex #Cortex2 Cortex_lib Counter Default Dot Dot_widget Egg Either Endpoint Environments FilenameExtra Fix Forest Functor Future Gettext_builder Hashmap Hashmmap Hashset HashtblExtra Ipv4 Ipv6 Lazy_perishable Linux ListExtra #Lock #Locked Log_builder MapExtra Marshallable_classes Memo Meta_ocamlbricks Mrproper MutexExtra Multimap Network Ocamlbricks_log OoExtra Oomarshal Option PervasivesExtra QueueExtra Rev Semaphore Shell SetExtra Spinning Stateful_modules StrExtra StringExtra String_queue Sugar StackExtra SysExtra ThreadExtra Thunk UnixExtra Widget Wrapper ocamlbricks-0.90+bzr456.orig/STRUCTURES/0000755000175000017500000000000013175721005016446 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/STRUCTURES/forest.ml0000644000175000017500000003523313175721005020310 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2007, 2008 Luca Saiu Copyright (C) 2007, 2010, 2012 Jean-Vincent Loddo Copyright (C) 2007, 2008, 2010, 2012 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Luca Saiu: initial version * - Jean-Vincent Loddo: minor changes (refactoring, comments, public interface) *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** This definition prevents equivalences (each forest as a unique representation). *) type 'a t = | Nil (** empty forest *) | Cons of ('a * 'a t) * (** first tree (root and subtrees) *) ('a t) (** other trees *) type 'a tree = 'a * 'a t (** a tree is a root with the forest of its children *) type 'a leaf = 'a (** a leaf is a tree without children *) let empty = Nil let is_empty t = (t=Nil) (** Prepend a tree to a forest. *) let cons t f = Cons (t,f) let add_tree = cons (** Prepend to a forest a tree which is a leaf. *) let cons_leaf (x:'a) t = Cons ((x,Nil),t) let add_leaf = cons_leaf (** Make a forest with a single tree. *) let of_tree t = Cons (t,Nil) let hd = function | Nil -> None | Cons(t, _) -> Some t let tl = function | Nil -> None | Cons(_, f) -> Some f let to_tree = function | Cons(t, Nil) -> t | _ -> invalid_arg "Forest.to_tree: the forest is not a singleton" (** Make a forest with a single tree which is a leaf. *) let of_leaf (x:'a leaf) = Cons ((x,Nil),Nil) let tree_of_leaf (x:'a leaf) : 'a tree = (x, Nil) (** Returns the list of the 'a elements belong the forest. The order is depth-first, left-to-right. *) let rec to_list : 'a t -> 'a list = function | Nil -> [] | Cons((root, subtrees), rest) -> root :: (List.append (to_list subtrees) (to_list rest)) (** Append the second forest at the end of the first one. *) let rec concat f1 f2 = match f1 with | Nil -> f2 | Cons(t1, f1) -> Cons(t1, concat f1 f2) (** Map the function over the 'a elements of the forest. *) let rec map f forest = match forest with Nil -> Nil | Cons((root, subtrees), rest) -> let root = f root in let subtrees = map f subtrees in let rest = map f rest in Cons((root, subtrees), rest) (** Iterate calling f on all nodes. The order is depth-first, left-to-right. f has the node as its first parameter, and its "parent-tree-node-option" as its second parameter *) let rec iter_pre_order ?parent (f : 'a -> 'a option -> unit) (forest : 'a t) = match forest with Nil -> () | Cons((root, subtrees), rest) -> begin f root parent; iter_pre_order ~parent:root f subtrees; iter_pre_order ?parent f rest end let rec iter_post_order ?parent (f : 'a -> 'a option -> unit) (forest : 'a t) = match forest with Nil -> () | Cons((root, subtrees), rest) -> begin iter_post_order ~parent:root f subtrees; f root parent; iter_post_order ?parent f rest end let iter ?post_order = match post_order with | None -> iter_pre_order | Some () -> iter_post_order (** Iterate calling f on all nodes. The order is depth-first, left-to-right. f has the node as its first parameter, and its "parent-tree-node-option" as its second parameter *) let rec fold_pre_order ?parent (f : 'b -> 'a -> 'a option -> 'b) acc (forest : 'a t) = match forest with Nil -> acc | Cons((root, subtrees), rest) -> begin let acc = f acc root parent in let acc = fold_pre_order ~parent:root f acc subtrees in let acc = fold_pre_order ?parent f acc rest in acc end let rec fold_post_order ?parent (f : 'b -> 'a -> 'a option -> 'b) acc (forest : 'a t) = match forest with Nil -> acc | Cons((root, subtrees), rest) -> begin let acc = fold_post_order ~parent:root f acc subtrees in let acc = f acc root parent in let acc = fold_post_order ?parent f acc rest in acc end let fold ?post_order = match post_order with | None -> fold_pre_order | Some () -> fold_post_order (** Bad nodes (which not verify the property p) are cut and orphans lifted up. *) let rec filter p forest = match forest with Nil -> Nil | Cons((root, subtrees), rest) -> let subtrees = filter p subtrees in let rest = filter p rest in if p root then Cons((root, subtrees), rest) else concat subtrees rest (** Return a list of all the nodes in the given forest satisfying the given predicate. The order is as usual depth-first, left-to-right. *) let rec nodes_such_that predicate forest = match forest with Nil -> [] | Cons((root, subtrees), rest) -> let switch = predicate root in let subtrees = nodes_such_that predicate subtrees in let rest = nodes_such_that predicate rest in let xs = List.append subtrees rest in if switch then root::xs else xs (** Return the node in the given forest satisfying the given predicate. The order is as usual depth-first, left-to-right. *) let rec search predicate forest = match forest with | Nil -> None | Cons((root, subtrees), rest) -> if predicate root then (Some root) else match (search predicate subtrees) with | None -> search predicate rest | x -> x ;; let search_and_replace pred repl t = map (fun a -> if pred a then repl a else a) t ;; (** Return the node in the given forest satisfying the given predicate. The order is as usual depth-first, left-to-right. Raises [Not_found] if the element is not found. *) let find predicate forest = match search predicate forest with | None -> raise Not_found | Some x -> x ;; (** Return the parent of a node satisfying the given predicate. The order is as usual depth-first, left-to-right. *) let parent_of_node_such_that predicate forest = let rec loop ?parent forest = match forest with | Nil -> None | Cons ((root, subtrees), rest) -> if predicate root then parent else match (loop ~parent:root subtrees) with | None -> loop ?parent rest | x -> x in loop forest ;; let parent_of node forest = parent_of_node_such_that ((=) node) forest ;; (** Return the first-level nodes (similar to 'find -maxdepth 1'). *) let rec roots_of = function | Nil -> [] | Cons((root, _), rest) -> root :: (roots_of rest) ;; (** Return a list of all the children of the given node in the given forest, in some unspecified order. Note that the given node may appear in several positions in the forest. In this case the result is the catenation of childrens of these occurrences. *) let children_nodes node forest = let rec children_nodes_of_existing_node node forest = match forest with Nil -> [] | Cons((root, subtrees), rest) -> if root = node then roots_of subtrees else List.append (children_nodes_of_existing_node node subtrees) (children_nodes_of_existing_node node rest) in match nodes_such_that (fun a_node -> a_node = node) forest with |[] -> failwith "children_nodes: node not existing" | _ -> children_nodes_of_existing_node node forest (** Return the root of the single child of the given node. Fail if the node has a number of children different from one. *) let child_node node forest = let singlet = children_nodes node forest in if List.length singlet <> 1 then failwith "child_node: the node has zero or more than one children" else List.hd singlet (** Return a list of all the descendant nodes of the given node in the given forest. The order is depth-first, left-to-right. *) let rec descendant_nodes node forest = match forest with Nil -> [] | Cons((root, subtrees), rest) -> if root = node then to_list subtrees else List.append (descendant_nodes node subtrees) (descendant_nodes node rest) (** Grandchildrens *) let grandchildren_nodes_with_repetitions node forest = let children_nodes_of_node = children_nodes node forest in List.flatten (List.map (fun node -> children_nodes node forest) children_nodes_of_node);; let printable_string_of_forest ?(level=0) ?(string_of_node=(fun _ ->"")) forest = let buffer = Buffer.create 100 in let print_string x = Buffer.add_string buffer x in let print_node x = Buffer.add_string buffer (string_of_node x) in (* Support for indentation *) let indent = function level -> for i = 1 to level do print_string " "; done; if level = 0 then print_string "* " else print_string "`-" in let rec loop ~level = function | Nil -> () | Cons((root, subtrees), rest) -> begin indent level; print_node root; print_string "\n"; loop ~level:(level + 1) subtrees; loop ~level rest; end in loop ~level forest; Buffer.contents buffer ;; (** A printer for forests: *) let rec print_forest ?level ?string_of_node ~channel forest = let s = printable_string_of_forest ?level ?string_of_node forest in Printf.kfprintf flush channel "%s" s ;; (** Add the given tree to the given forest, as a new child of every found node satisfying the given predicate. The new forest is returned *) let rec add_tree_to_forest_for_each predicate tree_root tree_subtrees forest = match forest with Nil -> Nil | Cons((root, subtrees), rest) -> if predicate root then let tree = (root, concat (add_tree_to_forest_for_each predicate tree_root tree_subtrees subtrees) (Cons((tree_root, tree_subtrees), Nil))) in Cons(tree, rest) else let tree = (root, (add_tree_to_forest_for_each predicate tree_root tree_subtrees subtrees)) in Cons(tree, (add_tree_to_forest_for_each predicate tree_root tree_subtrees rest)) (** Add the given tree to the given forest, as a new child of the only node satisfying the given predicate, or at toplevel if no node satisfies it. If more than a node in the forest satisfies the predicate an exception is raised. *) let add_tree_to_forest predicate tree_root tree_subtrees forest = let nodes = to_list forest in let satisfying_nodes = List.filter predicate nodes in let satisfying_nodes_length = List.length satisfying_nodes in if satisfying_nodes_length = 0 then concat forest (Cons((tree_root, tree_subtrees), Nil)) else if satisfying_nodes_length = 1 then add_tree_to_forest_for_each predicate tree_root tree_subtrees forest else failwith (Printf.sprintf "add_tree_to_forest predicate: more than one node (in fact %i) satisfies the predicate" satisfying_nodes_length) (* --- Jean --- facilities using forests to encode trees: *) (** Has the forest the form of a tree (i.e. a forest of length 1)? *) let is_tree = function | Cons (t,Nil) -> true | _ -> false (** Has the forest the form of a leaf? *) let is_leaf = function | Cons ((_,Nil),Nil) -> true | _ -> false (** A forest may be viewed as a list of trees. *) let rec to_treelist : 'a t -> 'a tree list = function | Nil -> [] | Cons (t,f) -> t::(to_treelist f) (** A list of forests may be viewed as a single big forest. The forests in the list are simply catenated. *) let rec of_forestlist : 'a t list -> 'a t = function | [] -> Nil | Nil::fs -> of_forestlist fs | (Cons (t,rest))::fs -> Cons (t, (concat rest (of_forestlist fs))) ;; (** A list of trees may be recompacted into a single forest. This function is similar to the [of_forestlist] but prevents the call to [concat] and also checks if all elements are really trees. An exception [Failure "of_nodelist"] is raised when a non tree element is encountered (use [of_forestlist] if you want flexibility). *) (*let rec of_treelist (l:'a t list) = match l with | [] -> Nil | (Cons (x,children,Nil))::l' -> Cons (x,children, (of_treelist l')) | _ -> failwith "of_nodelist" (* A run-time type checking *)*) let rec of_treelist : 'a tree list -> 'a t = function | [] -> Nil | t::ts -> Cons (t, (of_treelist ts)) (** Convert a list of unstructured elements into a forest of leafs. *) let of_list (l:'a list) = of_forestlist (List.map of_leaf l) (** {b Example}: {[let f = Forest.of_acyclic_relation (function 0->[1;2]|1->[3;4;5]|2->[6;7]|3->[8]| _ -> []) [0] in Forest.print_forest ~string_of_node:(string_of_int) f ~channel:stdout ;; * 0 `-1 `-3 `-8 `-4 `-5 `-2 `-6 `-7 ]} *) let of_acyclic_relation ~(successors:'a -> 'a list) ~(roots:'a list) : 'a t = let rec loop x : 'a tree = let children = successors x in let children_trees = List.map (loop) children in (x, (of_treelist children_trees)) in let treelist = List.map (loop) roots in of_treelist (treelist) let tree_of_acyclic_relation ~(successors:'a -> 'a list) ~(root:'a) : 'a tree = let rec loop x : 'a tree = let children = successors x in let children_trees = List.map (loop) children in (x, (of_treelist children_trees)) in loop root (** Back-propagation (from leafs to roots) of evaluations over a tree: *) let rec backprop_tree eval (root, subtrees) = let ts = to_treelist subtrees in let vs = List.map (backprop_tree eval) ts in eval root vs (** Parallel (using Futures) back-propagation (from leafs to roots) of evaluations over a tree: *) let rec backprop_tree_parallel eval (root, subtrees) = let ts = to_treelist subtrees in let futures = List.map (Future.future (backprop_tree_parallel eval)) ts in let vs = List.map (Future.touch) futures in eval root vs (** Back-propagation (from leafs to roots) of evaluations over a forest: *) let backprop eval forest = let ts = to_treelist forest in List.map (backprop_tree eval) ts (** Parallel (using Futures) back-propagation (from leafs to roots) of evaluations over a forest: *) let backprop_parallel eval forest = let ts = to_treelist forest in let futures = List.map (Future.future (backprop_tree_parallel eval)) ts in List.map (Future.touch) futures let rec sort compare forest = let xs = to_treelist forest in let ys = List.map (sort_tree compare) xs in let zs = List.sort (fun (root1,_) (root2,_) -> compare root1 root2) ys in of_treelist zs and sort_tree compare (root, subtrees) = let subtrees' = sort compare subtrees in (root, subtrees') ocamlbricks-0.90+bzr456.orig/STRUCTURES/semaphore.ml0000644000175000017500000001546513175721005020776 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Simple semaphore implementation for threads (not for processes). *) type t = { mutable counter : int ; condition : Condition.t ; mutex : Mutex.t ; } let create ?(mutex=Mutex.create ()) ?(condition=Condition.create ()) ?(init=0) () = { counter = init ; condition = condition ; mutex = mutex ; } (* Included here from MutexExtra for efficiency. *) let with_mutex mutex thunk = Mutex.lock mutex; try let result = thunk () in Mutex.unlock mutex; result with e -> begin Mutex.unlock mutex; (Printf.eprintf "Semaphore.with_mutex: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)); raise e; end let p ?(n=1) t = with_mutex t.mutex (fun () -> begin while (t.counter < n) do (Condition.wait t.condition t.mutex) done; t.counter <- t.counter - n end) let v ?(n=1) t = with_mutex t.mutex (fun () -> begin (t.counter <- t.counter + n); (Condition.signal t.condition); end) let p_nowait ?(n=1) t = with_mutex t.mutex (fun () -> begin if (t.counter < n) then false else ((t.counter <- t.counter - n); true) end) (** Execute thunk in a synchronized block (p ; code ; v), and return the value returned by the thunk. If executing thunk raises an exception the same exception is propagated, after correctly releasing (v) the semaphore. *) let with_semaphore ?(n=1) t thunk = p ~n t; try let result = thunk () in v ~n t; result with e -> begin v ~n t; (Printf.eprintf "Semaphore.with_semaphore: exception %s raised in critical section. Releasing and re-raising.\n" (Printexc.to_string e)); raise e; end (* Included here from ArrayExtra for efficiency. *) let exists (p : int -> 'a -> bool) (s:'a array) = let l = Array.length s in let rec loop i = if i>=l then false else (p i s.(i)) || loop (i+1) in loop 0 module Array_and (M:sig val dim:int end) = struct let dim = M.dim (* Run-time control on dimension. *) let () = assert (dim>0) (** Components are created on the same mutex and condition. *) let create ?(mutex=Mutex.create ()) ?(condition=Condition.create ()) ?(init=Array.make dim 0) () = Array.init dim (fun i -> create ~mutex ~condition ~init:init.(i) ()) let p ?(n=Array.make dim 1) t = let (mutex,condition) = (t.(0).mutex, t.(0).condition) in with_mutex mutex (fun () -> begin while exists (fun i s -> (s.counter < n.(i))) t do (Condition.wait condition mutex) done; Array.iteri (fun i s -> s.counter <- s.counter - n.(i)) t end) let v ?(n=Array.make dim 1) t = let (mutex,condition) = (t.(0).mutex, t.(0).condition) in with_mutex mutex (fun () -> begin (Array.iteri (fun i s -> s.counter <- s.counter + n.(i)) t); (Condition.broadcast condition); end) let p_nowait ?(n=Array.make dim 1) t = let (mutex,condition) = (t.(0).mutex, t.(0).condition) in with_mutex mutex (fun () -> begin if exists (fun i s -> (s.counter < n.(i))) t then false else ((Array.iteri (fun i s -> s.counter <- s.counter - n.(i)) t); true) end) (** Execute thunk in a synchronized block (p ; code ; v), and return the value returned by the thunk. If executing thunk raises an exception the same exception is propagated, after correctly releasing (v) the semaphore. *) let with_semaphore ?(n=Array.make dim 1) t thunk = p ~n t; try let result = thunk () in v ~n t; result with e -> begin v ~n t; (Printf.eprintf "Semaphore.with_semaphore: exception %s raised in critical section. Releasing and re-raising.\n" (Printexc.to_string e)); raise e; end type a = t array type t = a end (* Array_and *) (* Disjonctive semantics. *) module Array_or (M:sig val dim:int end) = struct let dim = M.dim (* Run-time control on dimension. *) let () = assert (dim>0) (** Components are created on the same mutex and condition. *) let create ?(mutex=Mutex.create ()) ?(condition=Condition.create ()) ?(init=Array.make dim 0) () = Array.init dim (fun i -> create ~mutex ~condition ~init:init.(i) ()) (* Auxiliary function similar to exists but setting the result (i,v) in a reference: *) let find ~aref p a = let l = Array.length a in let rec loop i = if i>=l then false else let x = a.(i) in if (p i x) then ((aref := Some i); true) else loop (i+1) in loop 0 let p ?(n=Array.make dim 1) t = let (mutex,condition) = (t.(0).mutex, t.(0).condition) in with_mutex mutex (fun () -> begin let aref = ref None in while not (find ~aref (fun i s -> (s.counter >= n.(i))) t) do (Condition.wait condition mutex) done; let i = match !aref with Some i -> i | None -> assert false in let k = n.(i) in (t.(i).counter <- t.(i).counter - k); (i,k) end) let v ~i ~n t = let (mutex,condition) = (t.(0).mutex, t.(0).condition) in with_mutex mutex (fun () -> begin (t.(i).counter <- t.(i).counter + n); (Condition.broadcast condition); end) let p_nowait ?(n=Array.make dim 1) t = let (mutex,condition) = (t.(0).mutex, t.(0).condition) in with_mutex mutex (fun () -> begin let aref = ref None in if find ~aref (fun i s -> (s.counter >= n.(i))) t then begin let i = match !aref with Some i -> i | None -> assert false in let k = n.(i) in (t.(i).counter <- t.(i).counter - k); Some (i,k) end else None end) (** Execute thunk in a synchronized block (p ; code ; v), and return the value returned by the thunk. If executing thunk raises an exception the same exception is propagated, after correctly releasing (v) the semaphore. *) let with_semaphore ?(n=Array.make dim 1) t f = let (i,k) = p ~n t in try let result = f ~i ~n:k in v ~i ~n:k t; result with e -> begin v ~i ~n:k t; (Printf.eprintf "Semaphore.with_semaphore: exception %s raised in critical section. Releasing and re-raising.\n" (Printexc.to_string e)); raise e; end type a = t array type t = a end (* Array_or *) ocamlbricks-0.90+bzr456.orig/STRUCTURES/forest.mli0000644000175000017500000000705313175721005020460 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo Copyright (C) 2012 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Luca Saiu: initial version * - Jean-Vincent Loddo: minor changes (refactoring, comments, public interface) *) (** A purely functional data structure for tree forests. For all iterators, the order of visit is always depth-first (pre-order), left-to-right. *) type 'a t type 'a tree = 'a * 'a t (** a tree is a root with the forest of its children *) type 'a leaf = 'a (** a leaf is a tree without children *) val empty : 'a t val is_empty : 'a t -> bool val add_tree : 'a tree -> 'a t -> 'a t val add_leaf : 'a leaf -> 'a t -> 'a t val of_tree : 'a tree -> 'a t val to_tree : 'a t -> 'a tree val of_leaf : 'a leaf -> 'a t val tree_of_leaf : 'a leaf -> 'a tree val is_tree : 'a t -> bool val is_leaf : 'a t -> bool val concat : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val iter : ?post_order:unit -> ?parent:'a -> ('a -> 'a option -> unit) -> 'a t -> unit val fold : ?post_order:unit -> ?parent:'a -> ('b -> 'a -> 'a option -> 'b) -> 'b -> 'a t -> 'b val backprop_tree : ('a -> 'b list -> 'b) -> 'a tree -> 'b val backprop_tree_parallel : ('a -> 'b list -> 'b) -> 'a tree -> 'b val backprop : ('a -> 'b list -> 'b) -> 'a t -> 'b list val backprop_parallel : ('a -> 'b list -> 'b) -> 'a t -> 'b list (** Sort all levels of the forest recursively. *) val sort : ('a -> 'a -> int) -> 'a t -> 'a t (** Sort all levels of the tree recursively. *) val sort_tree : ('a -> 'a -> int) -> 'a tree -> 'a tree val filter : ('a -> bool) -> 'a t -> 'a t val nodes_such_that : ('a -> bool) -> 'a t -> 'a list val parent_of_node_such_that : ('a -> bool) -> 'a t -> 'a option val find : ('a -> bool) -> 'a t -> 'a val search : ('a -> bool) -> 'a t -> 'a option val search_and_replace : ('a -> bool) -> ('a -> 'a) -> 'a t -> 'a t val parent_of : 'a -> 'a t -> 'a option val roots_of : 'a t -> 'a list val children_nodes : 'a -> 'a t -> 'a list val child_node : 'a -> 'a t -> 'a val descendant_nodes : 'a -> 'a t -> 'a list val grandchildren_nodes_with_repetitions : 'a -> 'a t -> 'a list val printable_string_of_forest : ?level:int -> ?string_of_node:('a -> string) -> 'a t -> string val print_forest : ?level:int -> ?string_of_node:('a -> string) -> channel:out_channel -> 'a t -> unit val add_tree_to_forest_for_each : ('a -> bool) -> 'a -> 'a t -> 'a t -> 'a t val add_tree_to_forest : ('a -> bool) -> 'a -> 'a t -> 'a t -> 'a t val to_treelist : 'a t -> 'a tree list val of_treelist : 'a tree list -> 'a t val of_forestlist : 'a t list -> 'a t val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list val tree_of_acyclic_relation : successors:('a -> 'a list) -> root:'a -> 'a tree val of_acyclic_relation : successors:('a -> 'a list) -> roots:('a list) -> 'a t ocamlbricks-0.90+bzr456.orig/STRUCTURES/either.mli0000644000175000017500000000370713175721005020440 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Operations on type [('a,'b) Either.t]. *) type ('a,'b) t = Left of 'a | Right of 'b type ('a,'b) either = ('a,'b) t (** Extract the encapsulated value. If the argument is [Left a], the optional [?fallback] is called on the value [a]. By default [fallback] is set to [fun _ -> failwith "Either.extract"].*) val extract : ?failwith_msg:string -> ?fallback:('a -> 'b) -> ('a,'b) t -> 'b val extract_or : ('a,'b) t -> 'b -> 'b val extract_or_force : ('a,'b) t-> 'b Lazy.t -> 'b val extract_from_list : ?acc:'b list -> ('a,'b) t list -> 'b list (* Raise Invalid_argument *) val get_left : ('a,'b) t -> 'a val get_right : ('a,'b) t -> 'b (* Injections: *) val left : 'a -> ('a,'b) t val right : 'b -> ('a,'b) t val iter : ('b -> unit) -> ('a,'b) t -> unit val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t val bind : ('a,'b) t -> ('b -> ('a,'c) t) -> ('a,'c) t val return : 'b -> ('a,'b) t val apply_or_catch : ('a -> 'b) -> 'a -> (exn, 'b) t val of_bool : bool -> (unit, unit) t val to_bool : ('a,'b) t -> bool val list_of : ('a,'b) t -> 'b list val to_string : ?a:('a -> string) -> ?b:('b -> string) -> ('a, 'b) t -> string module Bifunctor : sig val map : ('a0 -> 'a1) -> ('b0 -> 'b1) -> ('a0,'b0) t -> ('a1,'b1) t end ocamlbricks-0.90+bzr456.orig/STRUCTURES/counter.ml0000644000175000017500000000523413175721005020463 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type t = { mutable counter : int; mutable stack : (int list) } (* In this way there's a chance that the current value correspond to the number of already generated identifiers. *) let default_initial_value = 1 ;; (** Create a counter. *) let create ?(initial_value=default_initial_value) () = { counter = initial_value; stack = []; } (** Increment the counter in order to return a fresh integer. *) let fresh (c:t) = function () -> let result = c.counter in (c.counter <- c.counter + 1); result (** Open a parenthesis. All integers used after this action will be able to be recycled once the parenthesis will be closed. *) let open_parenthesis (c:t) = c.stack <- (c.counter)::(c.stack) (** Close the parenthesis. The counter is restored to the value which was assigned at the moment of last call to [open_parenthesis]. Raise a [Failure] if any parenthesis has been opened. *) let close_parenthesis (c:t) = match (c.stack) with | x::xs -> c.counter <- x ; c.stack <- xs | [] -> failwith "Counter.close_parenthesis: unbalanced usage of parenthesis." type 'a generator = unit -> 'a (** Create an int generator. *) let make_int_generator () = let t = create () in fresh t (** Create an string generator. *) let make_string_generator ?(prefix="") ?(suffix="") () = let g = make_int_generator () in function () -> Printf.sprintf "%s%i%s" prefix (g ()) suffix (** More sophisticated interface using objects: *) class c ?(initial_value=default_initial_value) () = let t = create ~initial_value () in object(self) method fresh = fresh t method open_parenthesis = open_parenthesis t method close_parenthesis = close_parenthesis t (* New methods: *) method set_next_fresh_value_to x = t.counter <- x method get_next_fresh_value = t.counter method reset = t.counter <- initial_value; t.stack <- []; end ocamlbricks-0.90+bzr456.orig/STRUCTURES/thunk.ml0000644000175000017500000002231313175721005020132 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type 'a t = unit -> 'a (** Transform a thunk in a one-shot thunk, i.e. a thunk that is not really executed more than once; the second and subsequent calls return immediately the previous result: *) let linearize thunk = let already_called = ref None in fun () -> match !already_called with | Some y -> y | None -> begin let y = thunk () in already_called := Some y; (* memoise *) y end let one_shot = linearize (** The resulting thunk will be protected from exceptions. It will translate all exceptions in the output [()]. *) let protect ~fallback thunk = (fun () -> try thunk () with _ -> fallback ()) (** Simply the application. *) let apply thunk = thunk () (** Conversion from lazy. Note that the result is directly a linear (one-shot) thunk because of the lazyness. However, the tool [linearize] still remains interesting for this kind of thunks. Actually, if the lazy value raises an exception, the resulting thunk raises this exception for each call, while the linearized one raises this exception only once. *) let of_lazy l = fun () -> Lazy.force l let to_lazy thunk = lazy (thunk ()) type id = int type linear = bool let rec first_success pred = function | [] -> None | t::ts -> let y = t () in (match (pred y) with | false -> first_success pred ts | true -> Some y ) let first_attempt p0 ts = let p1 = function None -> false | Some x -> p0 x in Option.join (first_success p1 ts) module Make_class_with_discipline (M : Container.T_with_identifiers) = struct let dress_thunk ?fallback ?one_shot thunk = let thunk = match fallback with | Some fallback -> protect ~fallback thunk | None -> thunk in let result = match one_shot with | Some () -> ((linearize thunk), true) (* linearize is not really needed here *) | None -> (thunk, false) in result class ['a] container ?fallback () = let fallback_default = fallback in object (self) val container = M.create () val mutable revno = 0 method revno = revno method register_thunk : ?fallback:'a t -> ?one_shot:unit -> 'a t -> id = fun ?fallback ?one_shot thunk -> let fallback = if fallback=None then fallback_default else fallback in let id = M.push (dress_thunk ?fallback ?one_shot thunk) container in revno <- revno + 1; id method register_lazy : ?fallback:'a t -> 'a Lazy.t -> id = fun ?fallback lazy_action -> let fallback = if fallback=None then fallback_default else fallback in let thunk = of_lazy lazy_action in let id = M.push (dress_thunk ?fallback ~one_shot:() thunk) container in revno <- revno + 1; id method apply : 'b. ?folder:('b -> 'a -> 'b) -> 'b -> 'b = fun ?folder acc -> (* Redefine the folder in order to apply the thunk, then the folder: *) let folder = match folder with | None -> (fun acc y -> acc) | Some f -> f in let folder acc (thunk, linear) = folder acc (thunk ()) in let result = M.fold folder acc container in let () = M.filter (fun (thunk, linear) -> not linear) container in result (* The application is delayed but it will act on the current (not the future) list of thunks. Note also that the one-shot thunks are immediately removed. *) method delayed_apply : 'b. ?folder:('b -> 'a -> 'b) -> 'b -> 'b Lazy.t = fun ?folder acc -> (* Redefine the folder in order to apply the thunk, then the folder: *) let folder = match folder with | None -> (fun acc y -> acc) | Some f -> f in let folder acc (thunk, linear) = folder acc (thunk ()) in let ts = M.to_list container in let () = M.filter (fun (thunk, linear) -> not linear) container in let result = lazy (List.fold_left folder acc ts) in result method remove id = M.remove_by_id id container; revno <- revno + 1 method get id = fst (M.get_by_id id container) end (* class container *) (* A special that deserves a special interface: *) class unit_protected_container () = let fallback_default () = () in object (self) val container = M.create () val mutable revno = 0 method revno = revno method register_thunk : ?unprotect:unit -> ?one_shot:unit -> 'a t -> id = fun ?unprotect ?one_shot thunk -> let fallback = if unprotect=None then (Some fallback_default) else None in let id = M.push (dress_thunk ?fallback ?one_shot thunk) container in revno <- revno + 1; id method register_lazy : ?unprotect:unit -> 'a Lazy.t -> id = fun ?unprotect lazy_action -> let fallback = if unprotect=None then (Some fallback_default) else None in let thunk = of_lazy lazy_action in let id = M.push (dress_thunk ?fallback ~one_shot:() thunk) container in revno <- revno + 1; id method apply : unit -> unit = fun () -> let () = M.iter (fun (thunk, linear) -> thunk ()) container in let () = M.filter (fun (thunk, linear) -> not linear) container in () method remove id = M.remove_by_id id container; revno <- revno + 1 method get id = fst (M.get_by_id id container) end (* class container *) end (* functor Make_class_with_discipline *) module FIFO_class_here = Make_class_with_discipline (Container.Queue_with_identifiers) module LIFO_class_here = Make_class_with_discipline (Container.Stack_with_identifiers) class ['a] fifo_container ?fallback () = object inherit ['a] FIFO_class_here.container ?fallback () method as_queue = container end class ['a] lifo_container ?fallback () = object inherit ['a] LIFO_class_here.container ?fallback () method as_stack = container end (** [unit] and protected thunks with a slightly different interface: *) class fifo_unit_protected_container () = object inherit FIFO_class_here.unit_protected_container () method as_queue = container end (** [unit] and protected thunks with a slightly different interface: *) class lifo_unit_protected_container () = object inherit LIFO_class_here.unit_protected_container () method as_stack = container end IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Test = struct (** {[ Thunk.Test.go () ;; Applying `q' a first time: --- I'm the thunk no. 1 (linear:false) I'm the thunk no. 2 (linear:true) I'm the thunk no. 3 (linear:false) I'm the thunk no. 4 (linear:false) Applying `s' a first time: --- I'm the thunk no. 4 (linear:false) I'm the thunk no. 3 (linear:false) I'm the thunk no. 2 (linear:true) I'm the thunk no. 1 (linear:false) Applying `q' a second time: --- I'm the thunk no. 1 (linear:false) I'm the thunk no. 3 (linear:false) I'm the thunk no. 4 (linear:false) Applying `s' a second time: --- I'm the thunk no. 4 (linear:false) I'm the thunk no. 3 (linear:false) I'm the thunk no. 1 (linear:false) Applying `q' a third time: --- I'm the thunk no. 1 (linear:false) I'm the thunk no. 4 (linear:false) Applying `s' a third time: --- I'm the thunk no. 4 (linear:false) I'm the thunk no. 1 (linear:false) : unit = () ]} *) let go () = let make ?(linear=false) i = let thunk () = Printf.printf "I'm the thunk no. %d (linear:%b)\n" i linear in thunk in let q = new fifo_container () in let () = ignore (q#register_thunk (make 1)) in let () = ignore (q#register_thunk ~one_shot:() (make ~linear:true 2)) in let i3 = q#register_thunk (make 3) in let () = ignore (q#register_thunk (make 4)) in let s = new lifo_container () in let () = ignore (s#register_thunk (make 1)) in let () = ignore (s#register_thunk ~one_shot:() (make ~linear:true 2)) in let j3 = s#register_thunk (make 3) in let () = ignore (s#register_thunk (make 4)) in let () = Printf.printf "Applying `q' a first time:\n---\n" in let () = q#apply () in let () = Printf.printf "Applying `s' a first time:\n---\n" in let () = s#apply () in let () = Printf.printf "Applying `q' a second time:\n---\n" in let () = q#apply () in let () = Printf.printf "Applying `s' a second time:\n---\n" in let () = s#apply () in let () = q#remove i3 in let () = s#remove j3 in let () = Printf.printf "Applying `q' a third time:\n---\n" in let () = q#apply () in let () = Printf.printf "Applying `s' a third time:\n---\n" in let () = s#apply () in () end (* module Test *) ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/cortex.mli0000644000175000017500000004310013175721005020453 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Generic and compositional data structure for safe threads interactions. Cortex stands for (CO)mpositional (R)eactive au(T)omata in mutual (EX)clusion. *) type 'a t val return : ?equality:('a -> 'a -> bool) -> ?on_proposal:('a -> 'a -> 'a) -> ?on_commit:('a -> 'a -> unit) -> 'a -> 'a t val of_object : ?equality:('a -> 'a -> bool) -> ?on_proposal:('a -> 'a -> 'a) -> ?on_commit:('a -> 'a -> unit) -> < get : 'a; set : 'a -> unit > -> 'a t val on_proposal_append : 'a t -> ('a -> 'a -> 'a) -> Thunk.id val on_proposal_remove : 'a t -> Thunk.id -> unit val on_proposal_clear : 'a t -> unit val on_commit_append : 'a t -> ('a -> 'a -> unit) -> Thunk.id val on_commit_remove : 'a t -> Thunk.id -> unit val on_commit_clear : 'a t -> unit (** Generic method call: *) val eval : ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'a t -> 'c * bool (** Facilities (specific and common `eval' instances): *) val get : ?guard:('a -> bool) -> 'a t -> 'a val set : ?guard:('a -> bool) -> 'a t -> 'a -> unit val propose : ?guard:('a -> bool) -> 'a t -> 'a -> 'a * bool val move : ?guard:('a -> bool) -> 'a t -> ('a -> 'a) -> 'a * bool val apply : ?guard:('a -> bool) -> 'a t -> ('a -> 'b) -> 'b module Async : sig val set : ?guard:('a -> bool) -> 'a t -> 'a -> unit val move : ?guard:('a -> bool) -> 'a t -> ('a -> 'a) -> unit end type ('a,'b) either = ('a,'b) Either.t type 'a scalar_or_cortex = ('a, ('a t)) either val scalar : 'a -> 'a scalar_or_cortex val cortex : 'a t -> 'a scalar_or_cortex (* ------------------------------------------- Connections ------------------------------------------- *) val connection : ?on_proposal:('b -> 'b -> 'b) -> ?on_commit:('b -> 'b -> unit) -> ?private_fellow:unit -> ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t val view : ?equality:('b -> 'b -> bool) -> ?on_proposal:('b -> 'b -> 'b) -> ?on_commit:('b -> 'b -> unit) -> ?private_fellow:unit -> ('a -> 'b) -> 'a t -> 'b t (* A wrapper is a connection with the identity functions: *) val wrapper : ?on_proposal:('a -> 'a -> 'a) -> ?on_commit:('a -> 'a -> unit) -> ?private_fellow:unit -> 'a t -> 'a t (* ------------------------------------------- Canonical products (tuples) ------------------------------------------- *) val group_pair : ?on_proposal:('a * 'b -> 'a * 'b -> 'a * 'b) -> ?on_commit:('a * 'b -> 'a * 'b -> unit) -> 'a t -> 'b t -> ('a * 'b) t val group_with_scalar : ?on_proposal:('a * 'b -> 'a * 'b -> 'a * 'b) -> ?on_commit:('a * 'b -> 'a * 'b -> unit) -> ('a scalar_or_cortex) -> ('b scalar_or_cortex) -> ('a *'b) t val group_triple : ?on_proposal:('a * 'b * 'c -> 'a * 'b * 'c -> 'a * 'b * 'c) -> ?on_commit:('a * 'b * 'c -> 'a * 'b * 'c -> unit) -> 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val group_quadruple : ?on_proposal:('a * 'b * 'c * 'd -> 'a * 'b * 'c * 'd -> 'a * 'b * 'c * 'd) -> ?on_commit:('a * 'b * 'c * 'd -> 'a * 'b * 'c * 'd -> unit) -> 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val group_quintuple : ?on_proposal:('a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd * 'e) -> ?on_commit:('a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd * 'e -> unit) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t val group_array : ?on_proposal:('a array -> 'a array -> 'a array) -> ?on_commit:('a array -> 'a array -> unit) -> ('a t) array -> ('a array) t val defuse : 'a t -> unit (* ------------------------------------------- Canonical sums (arrays, option, either) ------------------------------------------- *) val sum_array : ?on_proposal:(int * 'a -> int * 'a -> int * 'a) -> ?on_commit:(int * 'a -> int * 'a -> unit) -> 'a t array -> (int * 'a) t module Either : sig val iLeft : ?on_proposal:(('a,'b) either -> ('a,'b) either -> ('a,'b) either) -> ?on_commit:(('a,'b) either -> ('a,'b) either -> unit) -> ?right:('b t) -> 'a scalar_or_cortex -> (('a,'b) either) t val iRight : ?on_proposal:(('a,'b) either -> ('a,'b) either -> ('a,'b) either) -> ?on_commit:(('a,'b) either -> ('a,'b) either -> unit) -> ?left:('a t) -> 'b scalar_or_cortex -> (('a,'b) either) t end module Option : sig val iNone : ?on_proposal:('a option -> 'a option -> 'a option) -> ?on_commit:('a option -> 'a option -> unit) -> 'a t -> ('a option) t val iSome : ?on_proposal:('a option -> 'a option -> 'a option) -> ?on_commit:('a option -> 'a option -> unit) -> 'a t -> ('a option) t end (* ------------------------------------------- General products ------------------------------------------- *) module Product_pair : functor (Prod : sig type ('a,'b) t val prjA : ('a,'b) t -> 'a val prjB : ('a,'b) t -> 'b val make : 'a -> 'b -> ('a,'b) t end) -> sig (* This is the only function with an interface allowing the user to specify a scalar. In the other functors we will be able to compose only cortex. *) val make : ?on_proposal:(('a,'b) Prod.t -> ('a,'b) Prod.t -> ('a,'b) Prod.t) -> ?on_commit:(('a,'b) Prod.t -> ('a,'b) Prod.t -> unit) -> ('a scalar_or_cortex) -> ('b scalar_or_cortex) -> (('a,'b) Prod.t) t end module Product_triple : functor (Prod : sig type ('a,'b,'c) t val prjA : ('a,'b,'c) t -> 'a val prjB : ('a,'b,'c) t -> 'b val prjC : ('a,'b,'c) t -> 'c val make : 'a -> 'b -> 'c -> ('a,'b,'c) t end) -> sig val product_triple : ?on_proposal:(('a,'b,'c) Prod.t -> ('a,'b,'c) Prod.t -> ('a,'b,'c) Prod.t) -> ?on_commit:(('a,'b,'c) Prod.t -> ('a,'b,'c) Prod.t -> unit) -> 'a t -> 'b t -> 'c t -> (('a,'b,'c) Prod.t) t end module Product_quadruple : functor (Prod : sig type ('a,'b,'c,'d) t val prjA : ('a,'b,'c,'d) t -> 'a val prjB : ('a,'b,'c,'d) t -> 'b val prjC : ('a,'b,'c,'d) t -> 'c val prjD : ('a,'b,'c,'d) t -> 'd val make : 'a -> 'b -> 'c -> 'd -> ('a,'b,'c,'d) t end) -> sig val product_quadruple : ?on_proposal:(('a,'b,'c,'d) Prod.t -> ('a,'b,'c,'d) Prod.t -> ('a,'b,'c,'d) Prod.t) -> ?on_commit:(('a,'b,'c,'d) Prod.t -> ('a,'b,'c,'d) Prod.t -> unit) -> 'a t -> 'b t -> 'c t -> 'd t -> (('a,'b,'c,'d) Prod.t) t end module Product_quintuple : functor (Prod : sig type ('a,'b,'c,'d,'e) t val prjA : ('a,'b,'c,'d,'e) t -> 'a val prjB : ('a,'b,'c,'d,'e) t -> 'b val prjC : ('a,'b,'c,'d,'e) t -> 'c val prjD : ('a,'b,'c,'d,'e) t -> 'd val prjE : ('a,'b,'c,'d,'e) t -> 'e val make : 'a -> 'b -> 'c -> 'd -> 'e -> ('a,'b,'c,'d,'e) t end) -> sig val product_quintuple : ?on_proposal:(('a,'b,'c,'d,'e) Prod.t -> ('a,'b,'c,'d,'e) Prod.t -> ('a,'b,'c,'d,'e) Prod.t) -> ?on_commit:(('a,'b,'c,'d,'e) Prod.t -> ('a,'b,'c,'d,'e) Prod.t -> unit) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> (('a,'b,'c,'d,'e) Prod.t) t end (* ------------------------------------------- General sums ------------------------------------------- *) module Sum_pair : functor (Sum : sig type ('a,'b) t val injA : 'a -> ('a,'b) t val injB : 'b -> ('a,'b) t val case : ('a,'b) t -> ('a -> 'y) -> ('b -> 'y) -> 'y end) -> sig val injA : ?on_proposal:(('a,'b) Sum.t -> ('a,'b) Sum.t -> ('a,'b) Sum.t) -> ?on_commit:(('a,'b) Sum.t -> ('a,'b) Sum.t -> unit) -> ?b:('b t) -> 'a scalar_or_cortex -> (('a,'b) Sum.t) t val injB : ?on_proposal:(('a,'b) Sum.t -> ('a,'b) Sum.t -> ('a,'b) Sum.t) -> ?on_commit:(('a,'b) Sum.t -> ('a,'b) Sum.t -> unit) -> ?a:('a t) -> 'b scalar_or_cortex -> (('a,'b) Sum.t) t end module Sum_triple : functor (Sum : sig type ('a,'b,'c) t val injA : 'a -> ('a,'b,'c) t val injB : 'b -> ('a,'b,'c) t val injC : 'c -> ('a,'b,'c) t val case : ('a,'b,'c) t -> ('a -> 'y) -> ('b -> 'y) -> ('c -> 'y) -> 'y end) -> sig val injA : ?on_proposal:(('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t) -> ?on_commit:(('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t -> unit) -> ?b:('b t) -> ?c:('c t) -> 'a scalar_or_cortex -> (('a,'b,'c) Sum.t) t val injB : ?on_proposal:(('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t) -> ?on_commit:(('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t -> unit) -> ?a:('a t) -> ?c:('c t) -> 'b scalar_or_cortex -> (('a,'b,'c) Sum.t) t val injC : ?on_proposal:(('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t) -> ?on_commit:(('a,'b,'c) Sum.t -> ('a,'b,'c) Sum.t -> unit) -> ?a:('a t) -> ?b:('b t) -> 'c scalar_or_cortex -> (('a,'b,'c) Sum.t) t end module Sum_quadruple : functor (Sum : sig type ('a,'b,'c,'d) t val injA : 'a -> ('a,'b,'c,'d) t val injB : 'b -> ('a,'b,'c,'d) t val injC : 'c -> ('a,'b,'c,'d) t val injD : 'd -> ('a,'b,'c,'d) t val case : ('a,'b,'c,'d) t -> ('a -> 'y) -> ('b -> 'y) -> ('c -> 'y) -> ('d -> 'y) -> 'y end) -> sig val injA : ?on_proposal:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t) -> ?on_commit:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> unit) -> ?b:('b t) -> ?c:('c t) -> ?d:('d t) -> 'a scalar_or_cortex -> (('a,'b,'c,'d) Sum.t) t val injB : ?on_proposal:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t) -> ?on_commit:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> unit) -> ?a:('a t) -> ?c:('c t) -> ?d:('d t) -> 'b scalar_or_cortex -> (('a,'b,'c,'d) Sum.t) t val injC : ?on_proposal:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t) -> ?on_commit:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> unit) -> ?a:('a t) -> ?b:('b t) -> ?d:('d t) -> 'c scalar_or_cortex -> (('a,'b,'c,'d) Sum.t) t val injD : ?on_proposal:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t) -> ?on_commit:(('a,'b,'c,'d) Sum.t -> ('a,'b,'c,'d) Sum.t -> unit) -> ?a:('a t) -> ?b:('b t) -> ?c:('c t) -> 'd scalar_or_cortex -> (('a,'b,'c,'d) Sum.t) t end module Sum_quintuple : functor (Sum : sig type ('a,'b,'c,'d,'e) t val injA : 'a -> ('a,'b,'c,'d,'e) t val injB : 'b -> ('a,'b,'c,'d,'e) t val injC : 'c -> ('a,'b,'c,'d,'e) t val injD : 'd -> ('a,'b,'c,'d,'e) t val injE : 'e -> ('a,'b,'c,'d,'e) t val case : ('a,'b,'c,'d,'e) t -> ('a -> 'y) -> ('b -> 'y) -> ('c -> 'y) -> ('d -> 'y) -> ('e -> 'y) -> 'y end) -> sig val injA : ?on_proposal:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t) -> ?on_commit:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> unit) -> ?b:('b t) -> ?c:('c t) -> ?d:('d t) -> ?e:('e t) -> 'a scalar_or_cortex -> (('a,'b,'c,'d,'e) Sum.t) t val injB : ?on_proposal:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t) -> ?on_commit:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> unit) -> ?a:('a t) -> ?c:('c t) -> ?d:('d t) -> ?e:('e t) -> 'b scalar_or_cortex -> (('a,'b,'c,'d,'e) Sum.t) t val injC : ?on_proposal:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t) -> ?on_commit:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> unit) -> ?a:('a t) -> ?b:('b t) -> ?d:('d t) -> ?e:('e t) -> 'c scalar_or_cortex -> (('a,'b,'c,'d,'e) Sum.t) t val injD : ?on_proposal:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t) -> ?on_commit:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> unit) -> ?a:('a t) -> ?b:('b t) -> ?c:('c t) -> ?e:('e t) -> 'd scalar_or_cortex -> (('a,'b,'c,'d,'e) Sum.t) t val injE : ?on_proposal:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t) -> ?on_commit:(('a,'b,'c,'d,'e) Sum.t -> ('a,'b,'c,'d,'e) Sum.t -> unit) -> ?a:('a t) -> ?b:('b t) -> ?c:('c t) -> ?d:('d t) -> 'e scalar_or_cortex -> (('a,'b,'c,'d,'e) Sum.t) t end (* ------------------------------------------- Basic OO interfaces ------------------------------------------- *) module Object : sig class type ['a] public_interface = object method cortex_t : 'a t method eval : 'b 'c. ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'c * bool method get : ?guard:('a -> bool) -> unit -> 'a method set : ?guard:('a -> bool) -> 'a -> unit method propose : ?guard:('a -> bool) -> 'a -> 'a * bool method move : ?guard:('a -> bool) -> ('a -> 'a) -> 'a * bool method async : < set : ?guard:('a -> bool) -> 'a -> unit; move : ?guard:('a -> bool) -> ('a -> 'a) -> unit; > end class type ['a] private_interface = object method private cortex_t : 'a t method private eval : 'b 'c. ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'c * bool method private get : ?guard:('a -> bool) -> unit -> 'a method private set : ?guard:('a -> bool) -> 'a -> unit method private propose : ?guard:('a -> bool) -> 'a -> 'a * bool method private move : ?guard:('a -> bool) -> ('a -> 'a) -> 'a * bool method private async : < set : ?guard:('a -> bool) -> 'a -> unit; move : ?guard:('a -> bool) -> ('a -> 'a) -> unit; > end class ['a] with_public_interface : 'a t -> ['a] public_interface class ['a] with_private_interface : 'a t -> ['a] private_interface val with_public_interface : 'a t -> 'a public_interface val with_private_interface : 'a t -> 'a private_interface end (* Object *) (* Group-then-close strategy (instead of close-then-group) *) module Open : sig type 'a opn val return : ?equality:('a -> 'a -> bool) -> ?on_proposal:('a -> 'a -> 'a) -> ?on_commit:('a -> 'a -> unit) -> 'a -> ('a t) opn val close : 'a opn -> 'a val group_pair : ?on_proposal:('a * 'b -> 'a * 'b -> 'a * 'b) -> ?on_commit:('a * 'b -> 'a * 'b -> unit) -> 'a t opn -> 'b t opn -> ('a t * 'b t * ('a * 'b) t) opn val group_triple : ?on_proposal:('a * 'b * 'c -> 'a * 'b * 'c -> 'a * 'b * 'c) -> ?on_commit:('a * 'b * 'c -> 'a * 'b * 'c -> unit) -> 'a t opn -> 'b t opn -> 'c t opn -> ('a t * 'b t * 'c t * ('a * 'b * 'c) t) opn val group_quadruple : ?on_proposal:('a * 'b * 'c * 'd -> 'a * 'b * 'c * 'd -> 'a * 'b * 'c * 'd) -> ?on_commit:('a * 'b * 'c * 'd -> 'a * 'b * 'c * 'd -> unit) -> 'a t opn -> 'b t opn -> 'c t opn -> 'd t opn -> ('a t * 'b t * 'c t * 'd t * ('a * 'b * 'c * 'd) t) opn val group_quintuple : ?on_proposal:('a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd * 'e) -> ?on_commit:('a * 'b * 'c * 'd * 'e -> 'a * 'b * 'c * 'd * 'e -> unit) -> 'a t opn -> 'b t opn -> 'c t opn -> 'd t opn -> 'e t opn -> ('a t * 'b t * 'c t * 'd t * 'e t * ('a * 'b * 'c * 'd * 'e) t) opn val group_array : ?on_proposal:('a array -> 'a array -> 'a array) -> ?on_commit:('a array -> 'a array -> unit) -> 'a t opn array -> ('a t array * 'a array t) opn val lifes : ?on_proposal:(('a option * 'a t) -> ('a option * 'a t) -> ('a option * 'a t)) -> ?on_commit:(('a option * 'a t) -> ('a option * 'a t) -> unit) -> creator:(?previous:'a -> unit -> 'a t opn) -> terminal:('a -> bool) -> unit -> ('a option * 'a t) t opn val sum_array : ?on_proposal:(int * 'a -> int * 'a -> int * 'a) -> ?on_commit:(int * 'a -> int * 'a -> unit) -> 'a t opn array -> ('a t array * (int * 'a) t) opn module Product_pair : functor (Prod : sig type ('a,'b) t val prjA : ('a,'b) t -> 'a val prjB : ('a,'b) t -> 'b val make : 'a -> 'b -> ('a,'b) t end) -> sig val product_pair : ?on_proposal:(('a,'b) Prod.t -> ('a,'b) Prod.t -> ('a,'b) Prod.t) -> ?on_commit:(('a,'b) Prod.t -> ('a,'b) Prod.t -> unit) -> 'a t opn -> 'b t opn -> ('a t * 'b t * (('a,'b) Prod.t) t) opn end end (* module Open *) type 'a u = 'a t Open.opn (* ------------------------------------------- Leashed pointers ------------------------------------------- *) val lifes : ?on_proposal:(('a option * 'a t) -> ('a option * 'a t) -> ('a option * 'a t)) -> ?on_commit:(('a option * 'a t) -> ('a option * 'a t) -> unit) -> creator:(?previous:'a -> unit -> 'a u) -> terminal:('a -> bool) -> unit -> ('a option * 'a t) t (* ------------------------------------------- Examples ------------------------------------------- *) IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Make_Examples : functor (Void:sig end) -> sig module Example1 : sig val x : int t val y : int t val z : (int * int) t val w : (int, int) either t module Triad : sig type ('a, 'b, 'c) t = Apollo of 'a | Athena of 'b | Zeus of 'c end val t : (int, int, string) Triad.t t end module Example2 : sig val x : (int option * int t) t val y : int t val z : int t val look : ('a * 'b t) t -> 'b val member : ('a * 'b t) t -> 'b t end end (* functor Make_Examples() *) ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/ipv4.mli0000644000175000017500000000530013175721005020031 0ustar lucaslucas(* This file is part of Marionnet, a virtual network laboratory Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** IPv4 parsing and printing. *) (** The internal representation of an ipv4 address. *) type t = int * int * int * int (** The integer implicitely representing the netmask. Admissible values are in the range [0..32]. *) type cidr = int type netmask = t type port = int (** The internal representation of an ipv4 configuration, i.e. a pair [
/]. *) type config = t * cidr type verbose_config = t * netmask type socket = t * port (** Completion: *) val to_config : t -> config option (** {2 Netmask <-> CIDR} *) val netmask_of_cidr : cidr -> netmask val cidr_of_netmask : netmask -> cidr val netmask_of_string : string -> netmask (** {2 Parsing} *) val of_string : string -> t val to_string : t -> string val config_of_string : string -> config val string_of_config : config -> string val socket_of_string : string -> socket val string_of_socket : socket -> string val import : string -> (t, config) Either.t option type ipcalc_result = < ip : t; cidr : int; config : t * int; netmask : t; network : t; broadcast : t; hostmin : t; hostmax : t; hosts : int; print : unit; to_string : < ip : string; cidr : string; config : string; netmask : string; network : string; broadcast : string; hostmax : string; hostmin : string; >; contains : t -> bool; contains_socket : socket -> bool; > val ipcalc : t -> cidr -> ipcalc_result (** {2 String checking} *) module String : sig val is_valid_ipv4 : string -> bool val is_valid_netmask : string -> bool val is_valid_config : string -> bool val ipcalc : config:string -> < ip : string; cidr : string; netmask : string; network : string; broadcast : string; hostmax : string; hostmin : string; contains : ip:string -> bool; contains_socket : socket:string -> bool; print : unit; > end ocamlbricks-0.90+bzr456.orig/STRUCTURES/default.ml0000644000175000017500000000355313175721005020432 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) module Make (Value:sig type t val create : unit -> t val mutex : bool end) : sig type t = Value.t val get : unit -> t val set : t -> unit val extract_or_get_default : t option -> t end = struct type t = Value.t let default = ref None module Unprotected = struct (** Set the current default. *) let set s = (default := Some s) (** Get the current default if exists; create, set and return it if doesn't exist. *) let get () = match !default with | Some s -> s | None -> let new_default = Value.create () in (default := Some new_default); new_default (** If the argument is [Some x] return [x]; if the argument is [None], return the result of [get ()]. *) let extract_or_get_default = function | Some s -> s | None -> get () end (* Unprotected *) let mutex = MutexExtra.Recursive.create () let switch f = match Value.mutex with | true -> MutexExtra.Recursive.apply_with_mutex mutex f | false -> f let set = switch Unprotected.set let get = switch Unprotected.get let extract_or_get_default = switch Unprotected.extract_or_get_default end ocamlbricks-0.90+bzr456.orig/STRUCTURES/multimap.ml0000644000175000017500000001020013175721005020621 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** Multi-maps, i.e. maps x->y where x may be associated to zero or several y. They are simply implemented as maps of sets, with the condition that a multimap with a value x associated to the empty set, is equivalent to a multimap where x is unbound. *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../STRUCTURES/multimap.mli" ;; module Make (Ord_key : Map.OrderedType) (Ord_elt : Map.OrderedType) = struct type key = Ord_key.t type elt = Ord_elt.t type elt_set = SetExtra.Make(Ord_elt).t module Set = SetExtra.Make (Ord_elt) module Map = MapExtra.Make (Ord_key) type t = elt_set Map.t let empty = Map.empty let find x t = try Map.find x t with Not_found -> Set.empty let find_list ?sort x t = try Set.to_list ~reverse:(sort<>None) (Map.find x t) with Not_found -> [] let is_empty = Map.is_empty let add x y t = let s = find x t in let s' = Set.add y s in Map.add x s' t let remove_key = Map.remove let remove x y t = let s = find x t in let s' = Set.remove y s in if Set.is_empty s' then Map.remove x t else Map.add x s' t (** If the key is bound to the empty set is not really bound to something. *) let mem_key x t = try not (Set.is_empty (Map.find x t)) with Not_found -> false let mem x y t = try Set.mem y (Map.find x t) with Not_found -> false let fold_key = Map.fold let fold f = Map.fold (fun x s v -> Set.fold (f x) s v) let iter_key = Map.iter let iter f = Map.iter (fun x s -> Set.iter (f x) s) let remove_keys_bound_to_empty_set = Map.filter (fun x s -> not (Set.is_empty s)) let filter_key = Map.filter let filter f t = let t' = Map.mapi (fun x s -> Set.filter (f x) s) t in remove_keys_bound_to_empty_set t' let compare = Map.compare (Set.compare) let equal = Map.equal (Set.equal) let of_list ?(acc=Map.empty) xys = List.fold_left (fun t (x,y) -> add x y t) acc xys let to_list ?(acc=[]) ?sort t = let l = fold (fun x y t -> (x,y)::t) t acc in if (sort<>None) then List.rev l else l let domain ?sort = Map.domain ~reverse:(sort<>None) let codomain ?sorted_by_key t = let l = fold (fun x y ys -> y::ys) t [] in if (sorted_by_key<>None) then List.rev l else l let restrict = Map.restrict let inter t1 t2 = filter (fun x y -> mem x y t2) t1 let diff t1 t2 = filter (fun x y -> not (mem x y t2)) t1 let union t1 t2 = fold add t2 t1 end IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Examples = struct (* In order to haven't abstract types for key, elt and elt_set, the right way to apply the functor is the following: *) module Ord_key = struct type t = string let compare = Pervasives.compare end module Ord_elt = struct type t = int let compare = Pervasives.compare end module String2int : S with type key = Ord_key.t and type elt = Ord_elt.t and type elt_set = SetExtra.Make(Ord_elt).t = Make(Ord_key)(Ord_elt) module M = String2int let t = M.of_list [("x",2); ("x",1); ("y",3) ] let t' = M.of_list [("x",7); ("x",1); ("y",3); ("z",4) ] let diff = M.diff t t' let inter = M.inter t t' let union = M.union t t' let list_of_t = M.to_list ~sort:() t let list_of_t' = M.to_list ~sort:() t' let list_of_diff = M.to_list ~sort:() diff let list_of_inter = M.to_list ~sort:() inter let list_of_union = M.to_list ~sort:() union end (* module Examples *) ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/counter.mli0000644000175000017500000000370213175721005020632 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Generate unique identifiers. The defined structure includes a stack allowing to recycle identifiers (using functions [open_parenthesis] and [close_parenthesis]). *) type t val create : ?initial_value:int -> unit -> t val fresh : t -> unit -> int val open_parenthesis : t -> unit val close_parenthesis : t -> unit (** {b Example}: {[ # let c = Counter.create () ;; val c : Counter.t = # Counter.fresh c () ;; : int = 1 # Counter.fresh c () ;; : int = 2 # Counter.open_parenthesis c ;; : unit = () # Counter.fresh c () ;; : int = 3 # Counter.fresh c () ;; : int = 4 # Counter.close_parenthesis c ;; : unit = () # Counter.fresh c () ;; : int = 3 ]} *) (** {2 Simplified generators} *) type 'a generator = unit -> 'a val make_int_generator : unit -> int generator val make_string_generator : ?prefix:string -> ?suffix:string -> unit -> string generator (** {2 More sophisticated Object-oriented interface} *) class c : ?initial_value:int -> unit -> object method close_parenthesis : unit method fresh : unit -> int method open_parenthesis : unit method reset : unit method set_next_fresh_value_to : int -> unit method get_next_fresh_value : int end ocamlbricks-0.90+bzr456.orig/STRUCTURES/thunk.mli0000644000175000017500000001100113175721005020273 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Utilities about thunks, i.e. functions from [unit] to ['a]. *) type 'a t = unit -> 'a val linearize : 'a t -> 'a t val protect : fallback:(unit -> 'a) -> 'a t -> 'a t (** Alias for linearize: *) val one_shot : 'a t -> 'a t val apply : 'a t -> 'a val of_lazy : 'a lazy_t -> 'a t val to_lazy : 'a t -> 'a lazy_t type id = int type linear = bool (** First thunk providing a suitable result: *) val first_success : ('a -> bool) -> 'a t list -> 'a option (** As first_success, but each thunk may directly fails (None): *) val first_attempt : ('a -> bool) -> ('a option) t list -> 'a option (** A queue of 'a thunks. Linear (one-shot) thunks are automatically removed after each call of apply. Note that the first parameter of the folder is the accumulator (current state). *) class ['a] fifo_container : (* Default for methods having these parameters: *) ?fallback:'a t -> unit -> object method register_thunk : ?fallback:'a t -> ?one_shot:unit -> 'a t -> id method register_lazy : ?fallback:'a t -> 'a Lazy.t -> id method remove : id -> unit method get : id -> 'a t method revno : int method apply : 'b. ?folder:('b -> 'a -> 'b) -> 'b -> 'b (* The application is delayed but it will act on the current (not the future) list of thunks. Note also that the one-shot thunks are immediately removed. *) method delayed_apply : 'b. ?folder:('b -> 'a -> 'b) -> 'b -> 'b Lazy.t method as_queue : ('a t * linear) Container.Queue_with_identifiers.t end (** A stack of 'a thunks. Linear (one-shot) thunks are automatically removed after each call of apply. Note that the first parameter of the folder is the accumulator (current state). *) class ['a] lifo_container : (* Default for methods having these parameters: *) ?fallback:'a t -> unit -> object method register_thunk : ?fallback:'a t -> ?one_shot:unit -> 'a t -> id method register_lazy : ?fallback:'a t -> 'a Lazy.t -> id method remove : id -> unit method get : id -> 'a t method revno : int method apply : 'b. ?folder:('b -> 'a -> 'b) -> 'b -> 'b (* The application is delayed but it will act on the current (not the future) list of thunks. Note also that the one-shot thunks are immediately removed. *) method delayed_apply : 'b. ?folder:('b -> 'a -> 'b) -> 'b -> 'b Lazy.t method as_stack : ('a t * linear) Container.Stack_with_identifiers.t end class fifo_unit_protected_container : unit -> object method register_thunk : ?unprotect:unit -> ?one_shot:unit -> unit t -> id method register_lazy : ?unprotect:unit -> unit Lazy.t -> id method remove : id -> unit method get : id -> unit t method revno : int method apply : unit -> unit method as_queue : (unit t * linear) Container.Queue_with_identifiers.t end (** Useful to make a {e local} object-oriented mrproper structure. A typical use is to connect the method [apply] to the destruction of a temporary structure, as for instance a widget. {b Example}: {[ let window = GWindow.window () in let mrproper = new Thunk.lifo_unit_protected_container () in .. mrproper#register_lazy (lazy ...); mrproper#register_lazy (lazy ...); .. let _ = window#connect#destroy ~callback:mrproper#apply in .. ]}*) class lifo_unit_protected_container : unit -> object method register_thunk : ?unprotect:unit -> ?one_shot:unit -> unit t -> id method register_lazy : ?unprotect:unit -> unit Lazy.t -> id method remove : id -> unit method get : id -> unit t method revno : int method apply : unit -> unit method as_stack : (unit t * linear) Container.Stack_with_identifiers.t end IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Test : sig val go : unit -> unit end ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/option.ml0000644000175000017500000000776213175721005020324 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) type 'a t = 'a option let extract ?(failwith_msg="Option.extract") ?(fallback=(fun () -> failwith failwith_msg)) = function | None -> fallback () | Some x -> x let extract_or xo y = match xo with | Some x -> x | None -> y let extract_or_force xo y = match xo with | Some x -> x | None -> Lazy.force y let extract_map_or xo f y = match xo with | Some x -> f x | None -> y let map f = function None -> None | Some x -> Some (f x) let bind x f = match x with None -> None | Some x -> (f x) let return x = Some x let iter f = function None -> () | Some x -> (f x) let join = function | None -> None | Some x -> x (* Monadic definition: *) let map2 f m1 m2 = bind m1 (function x1 -> map (f x1) m2) let bind2 m1 m2 f = bind m1 (function x1 -> bind m2 (f x1)) let iter2 f m1 m2 = iter (function x1 -> iter (f x1) m2) m1 let filter p x = bind x (fun x -> if p x then Some x else None) let of_fallible_application ?(fallback=fun _ _ -> ()) f x = try Some (f x) with e -> ((fallback e x); None) let apply_or_catch ?(fallback=fun _ _ -> ()) f x = try Some (f x) with e -> ((fallback e x); None) let extract_from_list ?(acc=[]) xs = let rec loop = function | [] -> acc | None::xs -> (loop xs) | (Some x)::xs -> x::(loop xs) in loop xs let of_bool = function | false -> None | true -> Some () let to_bool = function | None -> false | Some _ -> true let to_list = function None -> [] | Some x -> [x] (* val split : ('a * 'b) option -> 'a option * 'b option *) let split = function | Some (x1,x2) -> (Some x1), (Some x2) | None -> None, None let split3 = function | Some (x1,x2,x3) -> (Some x1), (Some x2), (Some x3) | None -> None, None, None let split4 = function | Some (x1,x2,x3,x4) -> (Some x1), (Some x2), (Some x3), (Some x4) | None -> None, None, None, None let split5 = function | Some (x1,x2,x3,x4,x5) -> (Some x1), (Some x2), (Some x3), (Some x4), (Some x5) | None -> None, None, None, None, None (* val combine : 'a option -> 'b option -> ('a * 'b) option *) let map3 f m1 m2 m3 = bind m1 (function x1 -> map2 (f x1) m2 m3) let map4 f m1 m2 m3 m4 = bind m1 (function x1 -> map3 (f x1) m2 m3 m4) let map5 f m1 m2 m3 m4 m5 = bind m1 (function x1 -> map4 (f x1) m2 m3 m4 m5) let combine x y = map2 (fun x y -> (x,y)) x y let combine3 x y z = map3 (fun x y z -> (x,y,z)) x y z let combine4 x y z t = map4 (fun x y z t -> (x,y,z,t)) x y z t let combine5 x y z t u = map5 (fun x y z t u -> (x,y,z,t,u)) x y z t u (** {b Examples}: {[ # sprintf "[%4.2f]" None ;; : string = "None" # sprintf ~none:"NULL" "[%4.2f]" None ;; : string = "NULL" # Option.sprintf "[%4.2f]" (Some 3.14159) ;; : string = "Some [3.14]" # Option.sprintf ~frame:"(The result is %s)" "[%4.2f]" (Some 3.14159) ;; : string = "(The result is [3.14])" ]}*) let sprintf ?(none="None") ?frame fmt = function | None -> none | Some x -> (match frame with | None -> Printf.sprintf "Some %s" (Printf.sprintf fmt x) | Some fmt' -> Printf.sprintf fmt' (Printf.sprintf fmt x) ) let printf ?none ?frame fmt x = Printf.printf "%s" (sprintf ?none ?frame fmt x) let eprintf ?none ?frame fmt x = Printf.eprintf "%s" (sprintf ?none ?frame fmt x) let to_string ?none ?frame ?(a=fun _ -> "") x = let y = map a x in sprintf ?none ?frame "%s" y ocamlbricks-0.90+bzr456.orig/STRUCTURES/ipv6.ml0000644000175000017500000001723213175721005017671 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../STRUCTURES/ipv6.mli" ;; (** Convert a string into the ipv6 addresses internal representation. Raise [Invalid_argument] if the string is not in the valid standard format. *) let of_string s = if s = ":::" then (Array.make 8 0) else let scan_group group = let (i,rest) = Scanf.sscanf group "%4x%s" (fun i rest -> (i,rest)) in (assert (rest="")); i in try let xs = Str.split_delim (Str.regexp "::") s in let (ys,zs) = match List.map (Str.split_delim (Str.regexp ":")) xs with | [ys] -> (ys,[]) | [ys;zs] -> (ys,zs) | _ -> assert false in let ys = List.map scan_group ys in let zs = List.map scan_group zs in let ys = Array.of_list ys in let zs = Array.of_list zs in let n1 = Array.length ys in let n2 = Array.length zs in (assert (n1+n2 <= 8)); let zeros = Array.make (8-n1-n2) 0 in let result = Array.concat [ys; zeros; zs] in result with _ -> invalid_arg ("Ipv6.of_string: ill-formed ipv6 address "^s) (** Convert the internal representation of an ipv6 addresses into a string. *) let to_string ?uncompress t = (assert (Array.length t = 8)); if (ArrayExtra.for_all (fun _ -> (=) 0) t) then ":::" else let search_longest_sequence_of_zeros ?leftmost = ArrayExtra.search_longest_sequence ?leftmost ((=)0) in let to_string_list y = if Array.length y = 0 then [""] else Array.to_list (Array.map (Printf.sprintf "%x") y) in let xs = if uncompress = Some () then to_string_list t else match search_longest_sequence_of_zeros t with | Some (j,n) when n>1 -> let x1,_,x3 = match ArrayExtra.cut ~lengths:[j;n;(8-j-n)] t with | [x1;x2;x3] -> (x1,x2,x3) | _ -> assert false in let x1 = to_string_list x1 in let x2 = [""] in let x3 = to_string_list x3 in List.concat [x1;x2;x3] | _ -> to_string_list t in String.concat ":" xs (** Convert a string in the form ["xxxx:xxxx:..:xxxx/"] into its internal representation. *) let config_of_string (config:string) = match Option.apply_or_catch (Scanf.sscanf config "%s@/%i%s") (fun s i r -> (assert (r="")); (s,i)) with | None -> invalid_arg ("Ipv6.config_of_string: ill-formed address/cidr: "^config) | Some (s, cidr) -> if cidr < 0 || cidr > 128 then invalid_arg ("Ipv6.config_of_string: invalid cidr: "^(string_of_int cidr)) else begin match Option.apply_or_catch of_string s with | None -> invalid_arg ("Ipv6.config_of_string: ill-formed address: "^s) | Some t -> (t, cidr) end (** Convert the internal representation [(t,cidr)] into a string. *) let string_of_config ?uncompress (t,cidr) = let s = to_string ?uncompress t in Printf.sprintf "%s/%d" s cidr (** Determine all derived informations from the ipv6 address and cidr. {b Example}: {[# (Ipv6.ipcalc (Ipv6.of_string "abcd::7:8:9") 120)#print ;; Address: abcd::7:8:9 Netmask: ffff:ffff:ffff:ffff:ffff:ffff:ffff:ff00 = 120 => Network: abcd::7:8:0/120 HostMin: abcd::7:8:0 HostMax: abcd::7:8:ff : unit = () ]} *) let ipcalc (t as ip) cidr = (* Indexes of groups involved by the cidr value: *) let ((g1, g2), cidr4) = if cidr <=32 then ((0,1), cidr) else if cidr <=64 then ((2,3), cidr-32) else if cidr <=96 then ((4,5), cidr-64) else ((6,7), cidr-96) in let ipv4_of_two_groups x y = let x1,x2 = (x / 256), (x mod 256) in let y1,y2 = (y / 256), (y mod 256) in (x1,x2,y1,y2) in let group_of_semi_ipv4 x y = x*256 + y in let ipcalc4 = Ipv4.ipcalc (ipv4_of_two_groups t.(g1) t.(g2)) cidr4 in let netmask = let (i1,i2,i3,i4) = ipcalc4#netmask in Array.mapi (fun i group -> if ig2 then 0 else if i=g1 then group_of_semi_ipv4 i1 i2 else group_of_semi_ipv4 i3 i4) t in let network = let (i1,i2,i3,i4) = ipcalc4#network in Array.mapi (fun i group -> if ig2 then 0 else if i=g1 then group_of_semi_ipv4 i1 i2 else group_of_semi_ipv4 i3 i4) t in let hostmin = network in let hostmax = let (i1,i2,i3,i4) = ipcalc4#broadcast in Array.mapi (fun i group -> if ig2 then 65535 else(** IPv6 parsing and printing. *) if i=g1 then group_of_semi_ipv4 i1 i2 else group_of_semi_ipv4 i3 i4) t in let contains x = (x >= hostmin && x <= hostmax) in let s = to_string in let s_ip = lazy (s ip) in let s_cidr = lazy (string_of_int cidr) in let s_config = lazy (string_of_config (ip,cidr)) in let s_netmask = lazy (s netmask) in let s_network = lazy (s network) in let s_hostmin = lazy (s hostmin) in let s_hostmax = lazy (s hostmax) in object method ip = ip method cidr = cidr (** the provided cidr *) method config = (ip, cidr) method netmask = netmask method network = network method hostmax = hostmax method hostmin = hostmin method contains = contains method print = Printf.kfprintf flush stdout "Address: %s Netmask: %s = %d => Network: %s/%d HostMin: %s HostMax: %s " (Lazy.force s_ip) (Lazy.force s_netmask) cidr (Lazy.force s_network) cidr (Lazy.force s_hostmin) (Lazy.force s_hostmax) method to_string = object method ip = (Lazy.force s_ip) method cidr = (Lazy.force s_cidr) method config = (Lazy.force s_config) method netmask = (Lazy.force s_netmask) method network = (Lazy.force s_network) method hostmax = (Lazy.force s_hostmax) method hostmin = (Lazy.force s_hostmin) end end ;; (** Similar tools working on strings and producing strings. *) module String = struct let is_valid_ipv6 x = try let _ = of_string x in true with _ -> false let is_valid_config x = try let _ = config_of_string x in true with _ -> false (** Determine all derived informations from the ipv6 address and cidr provided in a unique string in the form ["xxxx:xxxx:..:xxxx/"]. {b Example}: {[ # (Ipv6.String.ipcalc "abcd::7:8:9/120")#print ;; Address: abcd::7:8:9 Netmask: ffff:ffff:ffff:ffff:ffff:ffff:ffff:ff00 = 120 => Network: abcd::7:8:0/120 HostMin: abcd::7:8:0 HostMax: abcd::7:8:ff : unit = () ]} *) let ipcalc ~config:config = match Option.apply_or_catch config_of_string config with | None -> invalid_arg ("Ipv6.String.ipcalc: ill-formed address/cidr: "^config) | Some (t, cidr) -> begin let x = ipcalc t cidr in object method ip = x#to_string#ip method cidr = x#to_string#cidr method netmask = x#to_string#netmask method network = x#to_string#network method hostmax = x#to_string#hostmax method hostmin = x#to_string#hostmin method contains = fun ~ip -> x#contains (of_string ip) method print = x#print end (* object *) end end (* module String *) ocamlbricks-0.90+bzr456.orig/STRUCTURES/future.ml0000644000175000017500000000370013175721005020312 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type 'a thread_status = | Completed of 'a | Exception of exn (** The abstract type of a future. *) type 'a future = (('a thread_status) Egg.t) * Thread.t (** Alias. *) type 'a t = 'a future (** Create a future applying an argument to a function. The result of the function may be got later with [touch] or [taste]. *) let future (f:'a -> 'b) (x:'a) : 'b t = let egg = Egg.create () in let wrap x = let y = (try Completed (f x) with e -> Exception e) in Egg.release egg y in let thd = Thread.create wrap x in (egg,thd) (** {b Wait} until the result is ready. Re-raise [exn] if the future has been interrupted by the exception [exn]. *) let touch (egg,thd) = match Egg.wait egg with | Completed y -> y | Exception e -> raise e (** Check if the result is ready (non-blocking): [None] means {e not ready}, while [Some y] means {e ready with value} [y]. Re-raise [exn] if the future has been interrupted by the exception [exn]. *) let taste (egg,thd) : 'a option = match Egg.taste egg with | None -> None | Some v -> (match v with | Completed y -> Some y | Exception e -> raise e ) let thread_of (egg,thd) = thd ocamlbricks-0.90+bzr456.orig/STRUCTURES/hashset.ml0000644000175000017500000000546613175721005020452 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** The default size of the hash used in the implementation *) let default_size = 251 class ['a] hashset = fun ?(size=default_size) () -> object (self) (** The state of the hashset. *) val hashtbl : ('a, unit) Hashtbl.t = (Hashtbl.create size) method hashtbl = hashtbl (** Answer (quickly!) to the question if x is a member of the set. *) method mem x = Hashtbl.mem hashtbl x (** Add the element to the set *) method add x = (Hashtbl.replace hashtbl x ()) (** Remove the element from the set *) method remove x = (Hashtbl.remove hashtbl x) end;; (* class hashset *) (* Functional interface. *) (** The abstract type of an hashset. *) type 'a t = 'a hashset (** The hashset constructor. *) let make ?(size=default_size) () : 'a t = new hashset ~size () (** The member predicate. *) let mem (hs:'a t) (x:'a) = hs#mem x (** Add a member to the hashset. *) let add (hs:'a t) (x:'a) = hs#add x (** Remove a member from the hashset. *) let remove (hs:'a t) (x:'a) = hs#remove x (** Make an hashset from a list. *) let of_list (l:'a list) : 'a t = let n = List.length l in let size = if n<(default_size/2) then default_size else n*2 in let hs = make ~size () in let () = (List.iter (add hs) l) in hs (** Make an hashset from a list. *) let of_array (xs:'a array) : 'a t = let n = Array.length xs in let size = if n<(default_size/2) then default_size else n*2 in let hs = make ~size () in let () = (Array.iter (add hs) xs) in hs let to_list (hs:'a t) = let xs = Hashtbl.fold (fun x () xs -> x::xs) hs#hashtbl [] in List.rev xs let to_array (hs:'a t) = Array.of_list (to_list hs) (** Exploit an hashset for implementing the uniq function over lists. *) let uniq (xs:'a list) : ('a list) = let hs = of_list xs in List.filter (fun x -> if hs#mem x then (hs#remove x; true) else false) xs let list_uniq = uniq let array_uniq (xs:'a array) : ('a array) = let hs = of_array xs in Array.of_list (List.filter (fun x -> if hs#mem x then (hs#remove x; true) else false) (Array.to_list xs)) ocamlbricks-0.90+bzr456.orig/STRUCTURES/hashset.mli0000644000175000017500000000303313175721005020607 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Polymorphic {e unbounded} sets. An encapsulated [('a, unit) Hashtbl.t] is used for quickly answering to the membership problem. *) type 'a t val make : ?size:int -> unit -> 'a t val mem : 'a t -> 'a -> bool val add : 'a t -> 'a -> unit val remove : 'a t -> 'a -> unit val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list val of_array : 'a array -> 'a t val to_array : 'a t -> 'a array val list_uniq : 'a list -> 'a list val array_uniq : 'a array -> 'a array val uniq : 'a list -> 'a list (* alias for list_uniq *) (** {2 Object-oriented interface} *) class ['a] hashset : ?size:int -> unit -> object method hashtbl : ('a, unit) Hashtbl.t method add : 'a -> unit method mem : 'a -> bool method remove : 'a -> unit end ocamlbricks-0.90+bzr456.orig/STRUCTURES/cortex.ml0000644000175000017500000022733713175721005020322 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* module Mutex = MutexExtra.Recursive *) (* A utiliser pour la construction `lifes', sinon pas nécessaires *) module Mutex = MutexExtra.Extended_Mutex module Mutex_group = struct module Mutex_set = Set.Make (struct type t = Mutex.t let compare = compare end) let merge_and_sort_mutex_lists l1 ls = let s = List.fold_left (fun s x -> Mutex_set.add x s) Mutex_set.empty l1 in let add s l2 = List.fold_left (fun s x -> Mutex_set.add x s) s l2 in let s = List.fold_left (add) s ls in Mutex_set.elements s type t = { head : Mutex.t; tail : Mutex.t list; reversed_tail : Mutex.t list; } let single () = { head = Mutex.create (); tail = []; reversed_tail = []; } let to_mutex_list t = t.head :: t.tail let of_ordered_mutex_list = function | m::ms -> let ws = List.rev ms in { head = m; tail = ms; reversed_tail = ws; } | [] -> assert false let group (t1 : t) (ts : t list) = let ms = let ms1 = to_mutex_list t1 in let msl = List.map to_mutex_list ts in merge_and_sort_mutex_lists ms1 msl in of_ordered_mutex_list ms let lock t = begin Mutex.lock t.head; List.iter Mutex.lock t.tail; end let unlock t = begin List.iter Mutex.unlock t.reversed_tail; Mutex.unlock t.head; end let wait alert t = begin List.iter Mutex.unlock t.reversed_tail; Mutex.wait alert t.head; List.iter Mutex.lock t.tail; end let apply_with_mutex (t:t) f x = lock t; try let result = f x in unlock t; result with e -> begin unlock t; raise e; end (* let with_mutex (t:t) thunk = apply_with_mutex t thunk () *) let with_mutex (t:t) thunk = lock t; try let result = thunk () in unlock t; result with e -> begin unlock t; raise e; end end (* module Mutex_group *) (* Basic notion of equality: *) let scalar_equality = fun s s' -> (s == s' || s = s') ;; module Unprotected = struct (* The structure of an unprotected cortex: *) type 'state t = { alert_on_commit : Condition.t; get_content : unit -> 'state; propose_content : 'state -> 'state; revno : int ref; waiting_no : int ref; equality : 'state -> 'state -> bool; on_proposal : ('state -> 'state -> 'state) Thunk.fifo_container; on_commit : ('state -> 'state -> unit) Thunk.fifo_container; (* "Private methods": *) on_proposal_container_unchanged : unit -> bool; no_longer_in_use : bool ref; equals_to_current : ('state -> bool) ref; } ;; (* Unprotected.make *) let make ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) ~(get_content:(unit -> 'state)) ?(set_content:('state -> unit) option) ?(propose_content:('state -> 'state) option) () : 'state t = let equality = match equality with | None -> scalar_equality | Some equality -> equality in (* Will be updated during commit: *) let initial_equals_to_current = let current = get_content () in (* The following partial application of the `equality' predicate is very relevant when the content is a reference (for example an object or a cortex): *) equality current in (* Work around for a strange problem of the type-checker about the recursive definition of `self': *) let (is_propose_content_provided, propose_content, set_content) = let unused = (fun proposal -> assert false) in match set_content, propose_content with | None , (Some f) -> (true, f, unused) | (Some f), None -> (false, unused, f) | _, _ -> invalid_arg "Cortex.make: ~set_content xor ~propose_content must be provided." in (* The record is morally an object: *) let rec self : 'state t = let alert_on_commit = Condition.create () in let on_proposal = let container = new Thunk.fifo_container ~fallback:(fun () -> fun s0 s1 -> s1) () in let () = Option.iter (fun f -> ignore (container#register_thunk (fun () -> f))) on_proposal in container in let on_commit = let container = new Thunk.fifo_container ~fallback:(fun () -> fun s0 s1 -> ()) () in let () = Option.iter (fun f -> ignore (container#register_thunk (fun () -> f))) on_commit in container in let on_proposal_container_unchanged = let previous_revno = ref 0 in fun () -> let current = self.on_proposal#revno in let result = (current = !previous_revno) in previous_revno := current; result in let propose_content (proposal) = if is_propose_content_provided then propose_content (proposal) else let () = set_content (proposal) in get_content () in { alert_on_commit = alert_on_commit; get_content = get_content; propose_content = propose_content; revno = ref 0; waiting_no = ref 0; equality = equality; equals_to_current = ref initial_equals_to_current; on_proposal = on_proposal; on_commit = on_commit; on_proposal_container_unchanged = on_proposal_container_unchanged; no_longer_in_use = ref false; } (* end of self definition *) in self (* Unprotected.return *) let return ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) (content:'state) = let cell = ref content in let get_content () = !cell in let set_content v = (cell := v) in make ?equality ?on_proposal ?on_commit ~get_content ~set_content () (* Unprotected.of_object *) let of_object ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) (x:< get:'state; set:'state -> unit; >) = let get_content () = x#get in let set_content v = x#set v in make ?equality ?on_proposal ?on_commit ~get_content ~set_content () (* Unprotected.revno_equality *) let revno_equality x = let r = x.revno in (fun x' -> x==x' && x'.revno = r) (* Unprotected.revno_or_content_equality *) let revno_or_content_equality : 'a t -> 'a t -> bool = fun x1 -> let r = x1.revno in fun x2 -> (x1==x2 && x2.revno = r) || (let v1 = x1.get_content () in let v2 = x2.get_content () in (x1.equality v1 v2) && (x2.equality v2 v1)) (* Unprotected.eval. The universal method, unprotected and without guards: *) let eval : 'a 'b. ('state -> 'a -> 'state * ('state -> 'b)) -> 'a -> 'state t -> 'b * bool * ('state * 'state) = fun f a t -> let equals_to_current = !(t.equals_to_current) in let current = t.get_content () in let (first_proposal, b_of_state) = (* Apply the update-proposal `f' *) f current a in (* This test is useful for thread waiting for a commit of a member which is no longer in use. This test is redundant because the thread should be stopped by the condition ~membership (see below): *) if !(t.no_longer_in_use) then ((b_of_state current), false, (current, current)) else if (equals_to_current first_proposal) && (t.on_proposal_container_unchanged ()) then (* No changes => no callbacks *) ((b_of_state current), false, (current, current)) else begin let rec local_fixpoint s = (* Again a partial application: *) let equals_to_s = (t.equality s) in let s' = (* Callbacks raising an exception are ignored: *) t.on_proposal#apply ~folder:(fun state f -> try f current state with _ -> state) s in if equals_to_s (s') then s else local_fixpoint s' in let locally_fixed_proposal = local_fixpoint first_proposal in (* A change should be observed, supposing the provided `set_content' or 'propose_content' agreed with the `locally_fixed_proposal': *) let rec global_fixpoint (s0:'a) : 'a * ('a -> bool) = let equals_to_s0 = (t.equality s0) in let s1 = t.propose_content (s0) in if equals_to_s0 (s1) then (s0, equals_to_s0) else let s2 = local_fixpoint s1 in global_fixpoint s2 in let globally_fixed_proposal, new_equals_to_current = global_fixpoint (locally_fixed_proposal) in let changed = not (equals_to_current globally_fixed_proposal) in if changed then begin (* A patch is really happened: *) t.revno := !(t.revno) + 1; t.equals_to_current := new_equals_to_current; if !(t.waiting_no) > 0 then begin (* let _ = Printf.kfprintf flush stderr "Cortex.eval: broadcasting to %d waiting threads\n" !(t.waiting_no) in *) Condition.broadcast (t.alert_on_commit); t.waiting_no := 0 end; end; (* if changed *) let result = ((b_of_state globally_fixed_proposal), changed, (current, globally_fixed_proposal)) in result end (* A fixed proposal has been calculated *) (* Unprotected.eval redefined: the third component of the result (the state) is given to the on_commit callbacks: *) let eval : 'a 'b. ('state -> 'a -> 'state * ('state -> 'b)) -> 'a -> 'state t -> 'b * bool = let are_there_on_commit_callbacks t = not (Container.Queue_with_identifiers.is_empty (t.on_commit#as_queue)) in fun f a t -> let (b, changed, (s0,s1)) = eval f a t in let () = if changed && (are_there_on_commit_callbacks t) then (* A unique thread is created to execute thunks sequentially with FIFO discipline: *) ignore (Thread.create (t.on_commit#apply ~folder:(fun () f -> try f s0 s1 with _ -> ())) ()) else () in (b, changed) (* Unprotected.propose. The `propose' specific case (useful for grouping): *) let eval_propose : 'state -> 'state t -> 'state * bool = fun s1 t -> eval (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t (* Unprotected.guarded_eval. Mutexes must be provided for waiting. Note that the evaluation starts immediately if the guard is verified. *) let guarded_eval : 'a 'b. guard:('state -> bool) -> mutexes:Mutex_group.t -> ('state -> 'a -> 'state * ('state -> 'b)) -> 'a -> 'state t -> 'b * bool = fun ~guard ~mutexes f a t -> let () = while not (guard (t.get_content ())) do incr (t.waiting_no); (* let _ = Printf.kfprintf flush stderr "Cortex.guarded_eval: entering wait (waiting_no = %d)\n" !(t.waiting_no) in *) Mutex_group.wait (t.alert_on_commit) mutexes; (* let _ = Printf.kfprintf flush stderr "Cortex.guarded_eval: exiting wait (waiting_no = %d)\n" !(t.waiting_no) in *) () done in eval f a t exception Membership_failure (* Mutexes must be provided for waiting. The cortex that commits is not necessarely the same that will be evaluated (even if by default is the same), but we suppose that the provided mutexes lock *both* cortex. Note also that we start waiting anyway: the evaluation will be executed after at least one commit. *) let eval_after_commit : ?monitored:('member t) -> (* the cortex that we are waiting for *) ?membership:(unit -> bool) -> ?guard:('state -> bool) -> mutexes:Mutex_group.t -> ('state -> 'a -> 'state * ('state -> 'b)) -> (* Arguments are flipped for efficiency: *) 'state t -> 'a -> ('b * bool) option = fun ?monitored ?(membership=(fun () -> true)) ?guard ~mutexes f t -> let (alert_on_commit, waiting_no) = match monitored with | None -> (t.alert_on_commit, t.waiting_no) | Some m -> (m.alert_on_commit, m.waiting_no) in let eval_without_guard a = begin (* Start waiting anyway: *) incr (waiting_no); Mutex_group.wait (alert_on_commit) mutexes; (* Eval after a commit (if the membership is still valid): *) if membership () then Some (eval f a t) else None end in let eval_with_guard guard a = begin try (* Start waiting anyway: *) incr (waiting_no); Mutex_group.wait (alert_on_commit) mutexes; (if not (membership ()) then raise Membership_failure); while not (guard (t.get_content ())) do incr (waiting_no); Mutex_group.wait (alert_on_commit) mutexes; (if not (membership ()) then raise Membership_failure); done; (* Eval after at least one commit: *) Some (eval f a t) with Membership_failure -> None end in match guard with | None -> eval_without_guard | Some guard -> eval_with_guard guard let repeat_eval_after_commit : ?monitored:('member t) -> (* the cortex that we are waiting for *) ?membership:(unit -> bool) -> ?guard:('state -> bool) -> ?signal_me_in_critical_section:(unit Egg.t) -> mutexes:Mutex_group.t -> ('state -> 'a -> 'state * ('state -> 'b)) -> 'state t -> (* the boolean result of `folder' denotes the `break' condition: *) folder:('c -> ('b * bool) -> 'c * bool) -> 'a -> 'c -> 'c = fun ?monitored ?membership ?guard ?signal_me_in_critical_section ~mutexes f t -> let () = Option.iter (fun egg -> Egg.release egg ()) (signal_me_in_critical_section) in let eval = eval_after_commit ?monitored ?membership ?guard ~mutexes f t in fun ~folder a c -> let rec loop c = match eval a with | None -> c (* A membership failure => break *) | Some r -> let (c', break) = folder c r in if break then c' else loop c' in loop c end (* module Unprotected *) (* Mutexes and related conditions are ordered by mutexes simply with Pervasives.compare. The inner evaluation is unprotected. *) type 'state t = Mutex_group.t * 'state Unprotected.t (* Recursive cortex? type 'a r = ('Mutex_group.t t) * 'a Unprotected.t *) (*let copy_but_already_protected_by ~mutexes t = (mutexes, snd t) ;;*) let make ?mutexes ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) ~(get_content:(unit -> 'state)) ?(set_content:('state -> unit) option) ?(propose_content:('state -> 'state) option) () : 'state t = let mutexes = match mutexes with | None -> Mutex_group.single () | Some mutexes -> mutexes in let u = Unprotected.make ?equality ?on_proposal ?on_commit ~get_content ?set_content ?propose_content () in (mutexes, u) (* The universal method (protected and guarded version): *) let eval : ?guard:('state -> bool) -> ('state -> 'a -> 'state * ('state -> 'b)) -> 'a -> 'state t -> 'b * bool = fun ?guard f a (mutexes, u) -> match guard with | None -> Mutex_group.apply_with_mutex mutexes (Unprotected.eval f a) u | Some guard -> Mutex_group.apply_with_mutex mutexes (Unprotected.guarded_eval ~guard ~mutexes f a) u (* Note that in the protected version the arguments are flipped with respect to the unprotected one. Warning: the monitored cortex, if provided, must be also locked by the mutexes of t. *) let eval_after_commit : ?monitored:('c t) -> (* the cortex that we are waiting for *) ?membership:(unit -> bool) -> ?guard:('state -> bool) -> ('state -> 'a -> 'state * ('state -> 'b)) -> 'a -> 'state t -> ('b * bool) option = fun ?monitored ?membership ?guard f a t -> let monitored = Option.map snd monitored in let (mutexes, u) = t in Mutex_group.apply_with_mutex mutexes (Unprotected.eval_after_commit ?monitored ?membership ?guard ~mutexes f u) a (* Note that in the protected version the arguments are flipped with respect to the unprotected one. Warning: the monitored cortex, if provided, must be also locked by the mutexes of t. *) let repeat_eval_after_commit : ?monitored:('m t) -> (* the cortex that we are waiting for *) ?membership:(unit -> bool) -> ?guard:('state -> bool) -> ?signal_me_in_critical_section:(unit Egg.t) -> folder:('c -> ('b * bool) -> 'c * bool) -> ('state -> 'a -> 'state * ('state -> 'b)) -> 'a -> 'state t -> 'c -> 'c = fun ?monitored ?membership ?guard ?signal_me_in_critical_section ~folder f a t c -> let monitored = Option.map snd monitored in let (mutexes, u) = t in Mutex_group.apply_with_mutex mutexes (Unprotected.repeat_eval_after_commit ?monitored ?membership ?guard ?signal_me_in_critical_section ~mutexes f u ~folder a) c let eval_get ?guard t = fst (eval ?guard (fun s () -> s, (fun s -> s)) () t) let eval_set ?guard s1 t = ignore (eval ?guard (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t) let eval_propose ?guard s1 t = eval ?guard (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t let eval_move ?guard f t = eval ?guard (fun s0 () -> (f s0), (fun s2 -> s2)) () t (* Flipped versions: *) let get ?guard t = fst (eval ?guard (fun s () -> s, (fun s -> s)) () t) let set ?guard t s1 = ignore (eval ?guard (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t) let propose ?guard t s1 = eval ?guard (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t let move ?guard t f = eval ?guard (fun s0 () -> (f s0), (fun s2 -> s2)) () t let apply ?guard t f = fst (eval ?guard (fun s () -> s, (fun s -> f s)) () t) let on_proposal_append (mutexes, u) thunk = Mutex_group.with_mutex mutexes (fun () -> u.Unprotected.on_proposal#register_thunk (fun () -> thunk)) let on_proposal_remove (mutexes, u) id = Mutex_group.with_mutex mutexes (fun () -> u.Unprotected.on_proposal#remove id) let on_proposal_clear (mutexes, u) = Mutex_group.with_mutex mutexes (fun () -> Container.Queue_with_identifiers.clear (u.Unprotected.on_proposal#as_queue)) let on_commit_append (mutexes, u) thunk = Mutex_group.with_mutex mutexes (fun () -> u.Unprotected.on_commit#register_thunk (fun () -> thunk)) let on_commit_remove (mutexes, u) id = Mutex_group.with_mutex mutexes (fun () -> u.Unprotected.on_commit#remove id) let on_commit_clear (mutexes, u) = Mutex_group.with_mutex mutexes (fun () -> Container.Queue_with_identifiers.clear (u.Unprotected.on_commit#as_queue)) (* Flipped and asynchronous versions: *) module Async = struct let set ?guard t s1 = ignore (Thread.create (fun () -> eval ?guard (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t) ()) let move ?guard t f = ignore (Thread.create (fun () -> eval ?guard (fun s0 () -> (f s0), (fun s2 -> s2)) () t) ()) end (* module Async *) (* May be also called `unit' or `create': 'a -> 'a t *) let return ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) (content:'state) = let cell = ref content in let get_content () = !cell in let set_content v = (cell := v) in make ?equality ?on_proposal ?on_commit ~get_content ~set_content () let of_object ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) (x:< get:'state; set:'state -> unit; >) = let get_content () = x#get in let set_content v = x#set v in make ?equality ?on_proposal ?on_commit ~get_content ~set_content () let repeat_move_proposal_to_group_on_member_commit : ?membership:(unit -> bool) -> ?guard:('state -> bool) -> ?signal_me_in_critical_section:(unit Egg.t) -> ?action_and_break_decision_when_accepted:('state -> 'state -> 'state -> bool) -> move_proposal:('state -> 'state) -> group:'state t -> 'member t -> unit = fun ?membership ?guard ?signal_me_in_critical_section ?(action_and_break_decision_when_accepted=fun _ _ _ -> false) ~move_proposal ~group member -> let monitored = member in (* The method is similar to `move' but the result is the triple of states (before_transition, proposed, after_transition): *) let mthd s0 () = let s1 = move_proposal s0 in (s1, (fun s2 -> (s0,s1,s2))) in let folder () ((s0,s1,s2), changed) = let break = if changed then (action_and_break_decision_when_accepted s0 s1 s2) else false in ((), break) in repeat_eval_after_commit ~monitored ?membership ?guard ?signal_me_in_critical_section ~folder mthd () group () let repeat_propose_to_group_on_member_commit ?membership ?guard ?signal_me_in_critical_section ?action_and_break_decision_when_accepted ~proposal ~group member = repeat_move_proposal_to_group_on_member_commit ?membership ?guard ?signal_me_in_critical_section ?action_and_break_decision_when_accepted ~move_proposal:(fun _ -> proposal ()) ~group member let eval_propose ?guard s1 t = eval ?guard (fun s0 s1 -> s1, (fun s2 -> s2)) s1 t type 'a scalar_or_cortex = ('a, ('a t)) Either.t let scalar x = Either.Left x let cortex x = Either.Right x let connection ?on_proposal ?on_commit ?private_fellow (f:'a->'b) (g:'b -> 'a) (member_x : 'a t) : 'b t = let (x_mutexes, x) = member_x in let mutexes = x_mutexes in let equality b = let equals_b = x.Unprotected.equality (g b) in fun b' -> equals_b (g b') in let proposal () = f (x.Unprotected.get_content ()) in let private_fellow : bool = (private_fellow = Some ()) in let x_bell = if private_fellow then None else Some (Egg.create ()) in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content a = begin let b = fst (Unprotected.eval_propose (g a) x) in let a' = f b in content_copy := a'; a' end and result : ('b t) Lazy.t = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in (* end of recursive definition *) let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:(Option.extract x_bell) ~membership ~proposal ~group (member) in (* If the encapsulated cortex is private (not accessible outside the connection), nobody will try to modify its state, so there is no need to install an observer: *) let _thd1 = if private_fellow then None else Some (Thread.create (trigger_on) (member_x)) in group) in let () = Option.iter (Egg.wait) x_bell in group let view ?equality ?on_proposal ?on_commit ?private_fellow (f:'a->'b) (member_x : 'a t) : 'b t = let (x_mutexes, x) = member_x in let mutexes = x_mutexes in let proposal () = f (x.Unprotected.get_content ()) in let private_fellow : bool = (private_fellow = Some ()) in let x_bell = if private_fellow then None else Some (Egg.create ()) in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content a = begin content_copy := a; a end and result : ('b t) Lazy.t = lazy (make ~mutexes ?equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in (* end of recursive definition *) let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:(Option.extract x_bell) ~membership ~proposal ~group (member) in (* If the encapsulated cortex is private (not accessible outside the connection), nobody will try to modify its state, so there is no need to install an observer: *) let _thd1 = if private_fellow then None else Some (Thread.create (trigger_on) (member_x)) in group) in let () = Option.iter (Egg.wait) x_bell in group let wrapper ?on_proposal ?on_commit ?private_fellow (member_x : 'a t) : 'a t = let (x_mutexes, x) = member_x in let mutexes = x_mutexes in let equality = x.Unprotected.equality in let proposal = x.Unprotected.get_content in let private_fellow : bool = (private_fellow = Some ()) in let x_bell = if private_fellow then None else Some (Egg.create ()) in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content v = begin let (v', b) = Unprotected.eval_propose v x in content_copy := v'; v' end and result : ('a t) Lazy.t = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in (* end of recursive definition *) let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:(Option.extract x_bell) ~membership ~proposal ~group (member) in (* If the encapsulated cortex is private (not accessible outside the connection), nobody will try to modify its state, so there is no need to install an observer: *) let _thd1 = if private_fellow then None else Some (Thread.create (trigger_on) (member_x)) in group) in let () = Option.iter (Egg.wait) x_bell in group module Product_pair (Prod : sig type ('a,'b) t val prjA : ('a,'b) t -> 'a val prjB : ('a,'b) t -> 'b val make : 'a -> 'b -> ('a,'b) t end) = struct let product_pair ?on_proposal ?on_commit ?private_a ?private_b (member_x : 'a t) (member_y : 'b t) : (('a,'b) Prod.t) t = let (x_mutexes, x) = member_x in let (y_mutexes, y) = member_y in let mutexes = Mutex_group.group x_mutexes [y_mutexes] in let private_a : bool = (private_a = Some ()) in let private_b : bool = (private_b = Some ()) in let equality v = let a, b = (Prod.prjA v), (Prod.prjB v) in let equals_a = (x.Unprotected.equality a) in let equals_b = (y.Unprotected.equality b) in fun v' -> let a', b' = (Prod.prjA v'), (Prod.prjB v') in (equals_a a') && (equals_b b') in let proposal () = Prod.make (x.Unprotected.get_content ()) (y.Unprotected.get_content ()) in let x_bell = if private_a then None else Some (Egg.create ()) in let y_bell = if private_b then None else Some (Egg.create ()) in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content v = begin let v1, v2 = (Prod.prjA v), (Prod.prjB v) in let (v1', b1) = Unprotected.eval_propose v1 x in let (v2', b2) = Unprotected.eval_propose v2 y in let v' = Prod.make v1' v2' in content_copy := v'; v' end and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~proposal ~group (member) in (* If a member is private (not accessible outside the group), nobody will try to modify its state, so there is no need to install an observer: *) let thread_create (private_flag) (obell) (member) = if private_flag then None else let bell = Option.extract obell in Some (Thread.create (trigger_on bell) (member)) in let _thd1 = thread_create (private_a) (x_bell) (member_x) in let _thd2 = thread_create (private_b) (y_bell) (member_y) in group) in let () = Option.iter (Egg.wait) x_bell in let () = Option.iter (Egg.wait) y_bell in group let make ?on_proposal ?on_commit (a:'a scalar_or_cortex) (b:'b scalar_or_cortex) : (('a,'b) Prod.t) t = let split_scalar_and_member = function | Either.Left scalar -> (Some scalar), None | Either.Right member -> None, (Some member) in let scalar_x, member_x = split_scalar_and_member (a) in let scalar_y, member_y = split_scalar_and_member (b) in let member_x, member_y = match member_x, member_y with | Some member_x, Some member_y -> member_x, member_y | Some ((x_mutexes,x) as member_x), None -> let member_y = let y_mutexes = x_mutexes in let y = Unprotected.return (Option.extract scalar_y) in (y_mutexes, y) in member_x, member_y | None, Some ((y_mutexes,y) as member_y) -> let member_x = let x_mutexes = y_mutexes in let x = Unprotected.return (Option.extract scalar_x) in (x_mutexes, x) in member_x, member_y | None, None -> assert false in let private_a = Option.map (fun _ -> ()) scalar_x in let private_b = Option.map (fun _ -> ()) scalar_y in product_pair ?on_proposal ?on_commit ?private_a ?private_b member_x member_y end (* Product_pair *) module Tuple2 = struct type ('a,'b) t = 'a * 'b let prjA (a,b) = a let prjB (a,b) = b let make a b = (a,b) end (* Tuple2 *) let group_pair ?on_proposal ?on_commit (member_x : 'a t) (member_y : 'b t) : ('a * 'b) t = let module M = Product_pair (Tuple2) in M.product_pair ?on_proposal ?on_commit (member_x) (member_y) let group_with_scalar ?on_proposal ?on_commit a b : ('a * 'b) t = let module M = Product_pair (Tuple2) in M.make ?on_proposal ?on_commit a b module Product_triple (Prod : sig type ('a,'b,'c) t val prjA : ('a,'b,'c) t -> 'a val prjB : ('a,'b,'c) t -> 'b val prjC : ('a,'b,'c) t -> 'c val make : 'a -> 'b -> 'c -> ('a,'b,'c) t end) = struct let product_triple ?on_proposal ?on_commit (member_x1 : 'a t) (member_x2 : 'b t) (member_x3 : 'c t) : (('a,'b,'c) Prod.t) t = let (x1_mutexes, x1) = member_x1 in let (x2_mutexes, x2) = member_x2 in let (x3_mutexes, x3) = member_x3 in let mutexes = Mutex_group.group x1_mutexes [x2_mutexes; x3_mutexes] in let equality v = let a, b, c = (Prod.prjA v), (Prod.prjB v), (Prod.prjC v) in let equals_a = (x1.Unprotected.equality a) in let equals_b = (x2.Unprotected.equality b) in let equals_c = (x3.Unprotected.equality c) in fun v' -> let a', b', c' = (Prod.prjA v'), (Prod.prjB v'), (Prod.prjC v') in (equals_a a') && (equals_b b') && (equals_c c') in let proposal () = Prod.make (x1.Unprotected.get_content ()) (x2.Unprotected.get_content ()) (x3.Unprotected.get_content ()) in let x1_bell = Egg.create () in let x2_bell = Egg.create () in let x3_bell = Egg.create () in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content v = begin let v1, v2, v3 = (Prod.prjA v), (Prod.prjB v), (Prod.prjC v) in let (v1', b1) = Unprotected.eval_propose v1 x1 in let (v2', b2) = Unprotected.eval_propose v2 x2 in let (v3', b3) = Unprotected.eval_propose v3 x3 in let v' = Prod.make v1' v2' v3' in content_copy := v'; v' end and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~proposal ~group (member) in let _thd1 = Thread.create (trigger_on x1_bell) (member_x1) in let _thd2 = Thread.create (trigger_on x2_bell) (member_x2) in let _thd3 = Thread.create (trigger_on x3_bell) (member_x3) in group) in let () = Egg.wait (x1_bell) in let () = Egg.wait (x2_bell) in let () = Egg.wait (x3_bell) in group end (* Product_triple *) let group_triple ?on_proposal ?on_commit (member_x1 : 'a t) (member_x2 : 'b t) (member_x3 : 'c t) : ('a * 'b * 'c) t = let module M = Product_triple ( struct type ('a,'b,'c) t = 'a * 'b * 'c let prjA (a,b,c) = a let prjB (a,b,c) = b let prjC (a,b,c) = c let make a b c = (a,b,c) end) in M.product_triple ?on_proposal ?on_commit (member_x1) (member_x2) (member_x3) module Product_quadruple (Prod : sig type ('a,'b,'c,'d) t val prjA : ('a,'b,'c,'d) t -> 'a val prjB : ('a,'b,'c,'d) t -> 'b val prjC : ('a,'b,'c,'d) t -> 'c val prjD : ('a,'b,'c,'d) t -> 'd val make : 'a -> 'b -> 'c -> 'd -> ('a,'b,'c,'d) t end) = struct let product_quadruple ?on_proposal ?on_commit (member_x1 : 'a t) (member_x2 : 'b t) (member_x3 : 'c t) (member_x4 : 'd t) : (('a,'b,'c,'d) Prod.t) t = let (x1_mutexes, x1) = member_x1 in let (x2_mutexes, x2) = member_x2 in let (x3_mutexes, x3) = member_x3 in let (x4_mutexes, x4) = member_x4 in let mutexes = Mutex_group.group x1_mutexes [x2_mutexes; x3_mutexes; x4_mutexes] in let equality v = let a, b, c, d = (Prod.prjA v), (Prod.prjB v), (Prod.prjC v), (Prod.prjD v) in let equals_a = (x1.Unprotected.equality a) in let equals_b = (x2.Unprotected.equality b) in let equals_c = (x3.Unprotected.equality c) in let equals_d = (x4.Unprotected.equality d) in fun v' -> let a', b', c', d' = (Prod.prjA v'), (Prod.prjB v'), (Prod.prjC v'), (Prod.prjD v') in (equals_a a') && (equals_b b') && (equals_c c') && (equals_d d') in let proposal () = Prod.make (x1.Unprotected.get_content ()) (x2.Unprotected.get_content ()) (x3.Unprotected.get_content ()) (x4.Unprotected.get_content ()) in let x1_bell = Egg.create () in let x2_bell = Egg.create () in let x3_bell = Egg.create () in let x4_bell = Egg.create () in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content v = begin let v1, v2, v3, v4 = (Prod.prjA v), (Prod.prjB v), (Prod.prjC v), (Prod.prjD v) in let (v1', b1) = Unprotected.eval_propose v1 x1 in let (v2', b2) = Unprotected.eval_propose v2 x2 in let (v3', b3) = Unprotected.eval_propose v3 x3 in let (v4', b4) = Unprotected.eval_propose v4 x4 in let v' = Prod.make v1' v2' v3' v4' in content_copy := v'; v' end and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~proposal ~group (member) in let _thd1 = Thread.create (trigger_on x1_bell) (member_x1) in let _thd2 = Thread.create (trigger_on x2_bell) (member_x2) in let _thd3 = Thread.create (trigger_on x3_bell) (member_x3) in let _thd4 = Thread.create (trigger_on x4_bell) (member_x4) in group) in let () = Egg.wait (x1_bell) in let () = Egg.wait (x2_bell) in let () = Egg.wait (x3_bell) in let () = Egg.wait (x4_bell) in group end (* Product_quadruple *) let group_quadruple ?on_proposal ?on_commit (member_x1 : 'a t) (member_x2 : 'b t) (member_x3 : 'c t) (member_x4 : 'd t) : ('a * 'b * 'c * 'd) t = let module M = Product_quadruple ( struct type ('a,'b,'c,'d) t = 'a * 'b * 'c * 'd let prjA (a,b,c,d) = a let prjB (a,b,c,d) = b let prjC (a,b,c,d) = c let prjD (a,b,c,d) = d let make a b c d = (a,b,c,d) end) in M.product_quadruple ?on_proposal ?on_commit (member_x1) (member_x2) (member_x3) (member_x4) module Product_quintuple (Prod : sig type ('a,'b,'c,'d,'e) t val prjA : ('a,'b,'c,'d,'e) t -> 'a val prjB : ('a,'b,'c,'d,'e) t -> 'b val prjC : ('a,'b,'c,'d,'e) t -> 'c val prjD : ('a,'b,'c,'d,'e) t -> 'd val prjE : ('a,'b,'c,'d,'e) t -> 'e val make : 'a -> 'b -> 'c -> 'd -> 'e -> ('a,'b,'c,'d,'e) t end) = struct let product_quintuple ?on_proposal ?on_commit (member_x1 : 'a t) (member_x2 : 'b t) (member_x3 : 'c t) (member_x4 : 'd t) (member_x5 : 'e t) : (('a,'b,'c,'d,'e) Prod.t) t = let (x1_mutexes, x1) = member_x1 in let (x2_mutexes, x2) = member_x2 in let (x3_mutexes, x3) = member_x3 in let (x4_mutexes, x4) = member_x4 in let (x5_mutexes, x5) = member_x5 in let mutexes = Mutex_group.group x1_mutexes [x2_mutexes; x3_mutexes; x4_mutexes; x5_mutexes] in let equality v = let a, b, c, d, e = (Prod.prjA v), (Prod.prjB v), (Prod.prjC v), (Prod.prjD v), (Prod.prjE v) in let equals_a = (x1.Unprotected.equality a) in let equals_b = (x2.Unprotected.equality b) in let equals_c = (x3.Unprotected.equality c) in let equals_d = (x4.Unprotected.equality d) in let equals_e = (x5.Unprotected.equality e) in fun v' -> let a', b', c', d', e' = (Prod.prjA v'), (Prod.prjB v'), (Prod.prjC v'), (Prod.prjD v'), (Prod.prjE v') in (equals_a a') && (equals_b b') && (equals_c c') && (equals_d d') && (equals_e e') in let proposal () = Prod.make (x1.Unprotected.get_content ()) (x2.Unprotected.get_content ()) (x3.Unprotected.get_content ()) (x4.Unprotected.get_content ()) (x5.Unprotected.get_content ()) in let x1_bell = Egg.create () in let x2_bell = Egg.create () in let x3_bell = Egg.create () in let x4_bell = Egg.create () in let x5_bell = Egg.create () in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content v = begin let v1, v2, v3, v4, v5 = (Prod.prjA v), (Prod.prjB v), (Prod.prjC v), (Prod.prjD v), (Prod.prjE v) in let (v1', b1) = Unprotected.eval_propose v1 x1 in let (v2', b2) = Unprotected.eval_propose v2 x2 in let (v3', b3) = Unprotected.eval_propose v3 x3 in let (v4', b4) = Unprotected.eval_propose v4 x4 in let (v5', b5) = Unprotected.eval_propose v5 x5 in let v' = Prod.make v1' v2' v3' v4' v5' in content_copy := v'; v' end and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~proposal ~group (member) in let _thd1 = Thread.create (trigger_on x1_bell) (member_x1) in let _thd2 = Thread.create (trigger_on x2_bell) (member_x2) in let _thd3 = Thread.create (trigger_on x3_bell) (member_x3) in let _thd4 = Thread.create (trigger_on x4_bell) (member_x4) in let _thd5 = Thread.create (trigger_on x5_bell) (member_x5) in group) in let () = Egg.wait (x1_bell) in let () = Egg.wait (x2_bell) in let () = Egg.wait (x3_bell) in let () = Egg.wait (x4_bell) in let () = Egg.wait (x5_bell) in group end (* Product_quintuple *) let group_quintuple ?on_proposal ?on_commit (member_x1 : 'a t) (member_x2 : 'b t) (member_x3 : 'c t) (member_x4 : 'd t) (member_x5 : 'e t) : ('a * 'b * 'c * 'd * 'e) t = let module M = Product_quintuple ( struct type ('a,'b,'c,'d,'e) t = 'a * 'b * 'c * 'd * 'e let prjA (a,b,c,d,e) = a let prjB (a,b,c,d,e) = b let prjC (a,b,c,d,e) = c let prjD (a,b,c,d,e) = d let prjE (a,b,c,d,e) = e let make a b c d e = (a,b,c,d,e) end) in M.product_quintuple ?on_proposal ?on_commit (member_x1) (member_x2) (member_x3) (member_x4) (member_x5) module Sum_pair (Sum : sig type ('a,'b) t val injA : 'a -> ('a,'b) t val injB : 'b -> ('a,'b) t val case : ('a,'b) t -> ('a -> 'y) -> ('b -> 'y) -> 'y end) = struct (* General tool used to build both injections: *) let make ?on_proposal ?on_commit ?initial ?(scalar_or_member_A : 'a scalar_or_cortex option) ?(scalar_or_member_B : 'b scalar_or_cortex option) () : (('a,'b) Sum.t) t = let split_scalar_and_member = function | None -> None, None | Some (Either.Left scalar) -> (Some scalar), None | Some (Either.Right member) -> None, (Some member) in let scalar_x, member_x = split_scalar_and_member (scalar_or_member_A) in let scalar_y, member_y = split_scalar_and_member (scalar_or_member_B) in let () = assert ((member_x <> None) || (member_y <> None)) in let x_mutexes, x_equality, x_move_proposal, x_initial, x_propose_content, x_bell = match member_x with | None -> (* The extraction fails if this component is set to be initial but the initial value is not provided: *) let x_initial () = Sum.injA (Option.extract scalar_x) in None, scalar_equality, Sum.injA, x_initial, Sum.injA, None | Some (x_mutexes, x) -> let x_equality = x.Unprotected.equality in let x_move_proposal = (fun _ -> Sum.injA (x.Unprotected.get_content ())) in let x_initial = (fun () -> Sum.injA (x.Unprotected.get_content ())) in let x_propose_content = fun a -> let a' = fst (Unprotected.eval_propose a x) in (Sum.injA a') in let x_bell = Some (Egg.create ()) in (Some x_mutexes, x_equality, x_move_proposal, x_initial, x_propose_content, x_bell) in let y_mutexes, y_equality, y_move_proposal, y_initial, y_propose_content, y_bell = match member_y with | None -> (* The extraction fails if this component is set to be initial but the initial value is not provided: *) let y_initial () = Sum.injB (Option.extract scalar_y) in None, scalar_equality, Sum.injB, y_initial, Sum.injB, None | Some (y_mutexes, y) -> let y_equality = y.Unprotected.equality in let y_move_proposal = (fun _ -> Sum.injB (y.Unprotected.get_content ())) in let y_initial = (fun () -> Sum.injB (y.Unprotected.get_content ())) in let y_propose_content = fun b -> let b' = fst (Unprotected.eval_propose b y) in (Sum.injB b') in let y_bell = Some (Egg.create ()) in (Some y_mutexes, y_equality, y_move_proposal, y_initial, y_propose_content, y_bell) in let mutexes = match x_mutexes, y_mutexes with | Some x_mutexes, None -> x_mutexes | None , Some y_mutexes -> y_mutexes | Some x_mutexes, Some y_mutexes -> Mutex_group.group x_mutexes [y_mutexes] | None, None -> assert false in let equality v = Sum.case v (fun a -> let equals_a = x_equality a in fun v' -> Sum.case v' (fun a' -> equals_a a') (fun _ -> false)) (fun b -> let equals_b = y_equality b in fun v' -> Sum.case v' (fun _ -> false) (fun b' -> equals_b b')) in let move_proposal v = Sum.case v (x_move_proposal) (y_move_proposal) in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = (* The initial state is by default the first component: *) let initial_state = let initial = match initial with | Some i -> i | None -> Sum.injA () in Sum.case initial (x_initial) (y_initial) in ref initial_state in let get_content () = !content_copy in let rec propose_content v = let v'= Sum.case v (x_propose_content) (y_propose_content) in content_copy := v'; v' and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_move_proposal_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~move_proposal ~group (member) in let create_thread_on = fun bell member -> Thread.create (trigger_on bell) (member) in let _thd1 = Option.map2 (create_thread_on) (x_bell) (member_x) in let _thd2 = Option.map2 (create_thread_on) (y_bell) (member_y) in group) in let () = Option.iter (Egg.wait) x_bell in let () = Option.iter (Egg.wait) y_bell in group let injA ?on_proposal ?on_commit ?b (a: 'a scalar_or_cortex): (('a,'b) Sum.t) t = make ?on_proposal ?on_commit ~initial:(Sum.injA ()) ~scalar_or_member_A:a ?scalar_or_member_B:(Option.map (Either.right) b) () let injB ?on_proposal ?on_commit ?a (b: 'b scalar_or_cortex) : (('a,'b) Sum.t) t = make ?on_proposal ?on_commit ~initial:(Sum.injB ()) ?scalar_or_member_A:(Option.map (Either.right) a) ~scalar_or_member_B:b () end (* Sum_pair *) module Either_cortex = struct module M = Sum_pair ( struct type ('a,'b) t = ('a,'b) Either.t let injA a = Either.Left a let injB b = Either.Right b let case t left right = match t with | Either.Left a -> left a | Either.Right b -> right b end) let iLeft ?on_proposal ?on_commit ?right e = M.injA ?on_proposal ?on_commit ?b:right e let iRight ?on_proposal ?on_commit ?left e = M.injB ?on_proposal ?on_commit ?a:left e (* Useful to build (encode) n-ary sums. The first argument, when provided, is set to be initial: *) let inject_two_optional_cortex (x:'a t option) (y:'b t option) : (('a,'b) Either.t) t option = match x,y with | None, None -> None | Some x, _ -> Some (iLeft ?right:y (Either.Right x)) | None, Some y -> Some (iRight ?left:None (Either.Right y)) end module Sum_triple (Sum : sig type ('a,'b,'c) t val injA : 'a -> ('a,'b,'c) t val injB : 'b -> ('a,'b,'c) t val injC : 'c -> ('a,'b,'c) t val case : ('a,'b,'c) t -> ('a -> 'y) -> ('b -> 'y) -> ('c -> 'y) -> 'y end) = struct (* Original sum type (s) and its implementation with Either (t): *) type ('a,'b,'c) s0 = ('a,'b,'c) Sum.t type ('a,'b,'c) s1 = ('a, (('b,'c) Either.t)) Either.t let s0_of_s1 = function | Either.Left a -> Sum.injA a | Either.Right (Either.Left b) -> Sum.injB b | Either.Right (Either.Right c) -> Sum.injC c let s1_of_s0 x = Sum.case x (fun a -> Either.Left a) (fun b -> Either.Right (Either.Left b)) (fun c -> Either.Right (Either.Right c)) let injA ?on_proposal ?on_commit ?(b: 'b t option) ?(c:'c t option) (a: 'a scalar_or_cortex) : (('a,'b,'c) Sum.t) t = let t1 : (('a,'b,'c) s1) t = let member_bc = Either_cortex.inject_two_optional_cortex b c in Either_cortex.iLeft ?right:member_bc a in let t0 : (('a,'b,'c) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injB ?on_proposal ?on_commit ?(a: 'a t option) ?(c:'c t option) (b: 'b scalar_or_cortex) : (('a,'b,'c) Sum.t) t = let t1 : (('a,'b,'c) s1) t = let member_bc = Either_cortex.iLeft ?right:c b in Either_cortex.iRight ?left:a (Either.Right member_bc) in let t0 : (('a,'b,'c) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injC ?on_proposal ?on_commit ?(a: 'a t option) ?(b:'b t option) (c: 'c scalar_or_cortex) : (('a,'b,'c) Sum.t) t = let t1 : (('a,'b,'c) s1) t = let member_bc = Either_cortex.iRight ?left:b c in Either_cortex.iRight ?left:a (Either.Right member_bc) in let t0 : (('a,'b,'c) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 end module Sum_quadruple (Sum : sig type ('a,'b,'c,'d) t val injA : 'a -> ('a,'b,'c,'d) t val injB : 'b -> ('a,'b,'c,'d) t val injC : 'c -> ('a,'b,'c,'d) t val injD : 'd -> ('a,'b,'c,'d) t val case : ('a,'b,'c,'d) t -> ('a -> 'y) -> ('b -> 'y) -> ('c -> 'y) -> ('d -> 'y) -> 'y end) = struct (* Original sum type (s) and its implementation with Either (t): *) type ('a,'b,'c,'d) s0 = ('a,'b,'c,'d) Sum.t type ('a,'b,'c,'d) s1 = ('a, ('b, (('c,'d) Either.t)) Either.t) Either.t let s0_of_s1 = function | Either.Left a -> Sum.injA a | Either.Right (Either.Left b) -> Sum.injB b | Either.Right (Either.Right (Either.Left c)) -> Sum.injC c | Either.Right (Either.Right (Either.Right d)) -> Sum.injD d let s1_of_s0 x = Sum.case x (fun a -> Either.Left a) (fun b -> Either.Right (Either.Left b)) (fun c -> Either.Right (Either.Right (Either.Left c))) (fun d -> Either.Right (Either.Right (Either.Right d))) let injA ?on_proposal ?on_commit ?(b: 'b t option) ?(c:'c t option) ?(d:'d t option) (a: 'a scalar_or_cortex) : (('a,'b,'c,'d) Sum.t) t = let t1 : (('a,'b,'c,'d) s1) t = let member_cd = Either_cortex.inject_two_optional_cortex c d in let member_bcd = Either_cortex.inject_two_optional_cortex b member_cd in Either_cortex.iLeft ?right:member_bcd a in let t0 : (('a,'b,'c,'d) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injB ?on_proposal ?on_commit ?(a: 'a t option) ?(c:'c t option) ?(d:'d t option) (b: 'b scalar_or_cortex) : (('a,'b,'c,'d) Sum.t) t = let t1 : (('a,'b,'c,'d) s1) t = let member_cd = Either_cortex.inject_two_optional_cortex c d in let member_bcd = Either_cortex.iLeft ?right:member_cd b in Either_cortex.iRight ?left:a (Either.Right member_bcd) in let t0 : (('a,'b,'c,'d) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injC ?on_proposal ?on_commit ?(a: 'a t option) ?(b:'b t option) ?(d:'d t option) (c: 'c scalar_or_cortex) : (('a,'b,'c,'d) Sum.t) t = let t1 : (('a,'b,'c,'d) s1) t = let member_cd = Either_cortex.iLeft ?right:d c in let member_bcd = Either_cortex.iRight ?left:b (Either.Right member_cd) in Either_cortex.iRight ?left:a (Either.Right member_bcd) in let t0 : (('a,'b,'c,'d) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injD ?on_proposal ?on_commit ?(a: 'a t option) ?(b:'b t option) ?(c:'c t option) (d: 'd scalar_or_cortex) : (('a,'b,'c,'d) Sum.t) t = let t1 : (('a,'b,'c,'d) s1) t = let member_cd = Either_cortex.iRight ?left:c d in let member_bcd = Either_cortex.iRight ?left:b (Either.Right member_cd) in Either_cortex.iRight ?left:a (Either.Right member_bcd) in let t0 : (('a,'b,'c,'d) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 end (* Sum_quadruple *) module Sum_quintuple (Sum : sig type ('a,'b,'c,'d,'e) t val injA : 'a -> ('a,'b,'c,'d,'e) t val injB : 'b -> ('a,'b,'c,'d,'e) t val injC : 'c -> ('a,'b,'c,'d,'e) t val injD : 'd -> ('a,'b,'c,'d,'e) t val injE : 'e -> ('a,'b,'c,'d,'e) t val case : ('a,'b,'c,'d,'e) t -> ('a -> 'y) -> ('b -> 'y) -> ('c -> 'y) -> ('d -> 'y) -> ('e -> 'y) -> 'y end) = struct (* Original sum type (s) and its implementation with Either (t): *) type ('a,'b,'c,'d,'e) s0 = ('a,'b,'c,'d,'e) Sum.t type ('a,'b,'c,'d,'e) s1 = ('a, ('b, ('c, (('d,'e) Either.t)) Either.t) Either.t) Either.t let s0_of_s1 = function | Either.Left a -> Sum.injA a | Either.Right (Either.Left b) -> Sum.injB b | Either.Right (Either.Right (Either.Left c)) -> Sum.injC c | Either.Right (Either.Right (Either.Right (Either.Left d))) -> Sum.injD d | Either.Right (Either.Right (Either.Right (Either.Right e))) -> Sum.injE e let s1_of_s0 x = Sum.case x (fun a -> Either.Left a) (fun b -> Either.Right (Either.Left b)) (fun c -> Either.Right (Either.Right (Either.Left c))) (fun d -> Either.Right (Either.Right (Either.Right (Either.Left d)))) (fun e -> Either.Right (Either.Right (Either.Right (Either.Right e)))) let injA ?on_proposal ?on_commit ?(b: 'b t option) ?(c:'c t option) ?(d:'d t option) ?(e:'e t option) (a: 'a scalar_or_cortex) : (('a,'b,'c,'d,'e) Sum.t) t = let t1 : (('a,'b,'c,'d,'e) s1) t = let member_de = Either_cortex.inject_two_optional_cortex d e in let member_cde = Either_cortex.inject_two_optional_cortex c member_de in let member_bcde = Either_cortex.inject_two_optional_cortex b member_cde in Either_cortex.iLeft ?right:member_bcde a in let t0 : (('a,'b,'c,'d,'e) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injB ?on_proposal ?on_commit ?(a: 'a t option) ?(c:'c t option) ?(d:'d t option) ?(e:'e t option) (b: 'b scalar_or_cortex) : (('a,'b,'c,'d,'e) Sum.t) t = let t1 : (('a,'b,'c,'d,'e) s1) t = let member_de = Either_cortex.inject_two_optional_cortex d e in let member_cde = Either_cortex.inject_two_optional_cortex c member_de in let member_bcde = Either_cortex.iLeft ?right:member_cde b in Either_cortex.iRight ?left:a (Either.Right member_bcde) in let t0 : (('a,'b,'c,'d,'e) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injC ?on_proposal ?on_commit ?(a: 'a t option) ?(b:'b t option) ?(d:'d t option) ?(e:'e t option) (c: 'c scalar_or_cortex) : (('a,'b,'c,'d,'e) Sum.t) t = let t1 : (('a,'b,'c,'d,'e) s1) t = let member_de = Either_cortex.inject_two_optional_cortex d e in let member_cde = Either_cortex.iLeft ?right:member_de c in let member_bcde = Either_cortex.iRight ?left:b (Either.Right member_cde) in Either_cortex.iRight ?left:a (Either.Right member_bcde) in let t0 : (('a,'b,'c,'d,'e) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injD ?on_proposal ?on_commit ?(a: 'a t option) ?(b:'b t option) ?(c:'c t option) ?(e:'e t option) (d: 'd scalar_or_cortex) : (('a,'b,'c,'d,'e) Sum.t) t = let t1 : (('a,'b,'c,'d,'e) s1) t = let member_de = Either_cortex.iLeft ?right:e d in let member_cde = Either_cortex.iRight ?left:c (Either.Right member_de) in let member_bcde = Either_cortex.iRight ?left:b (Either.Right member_cde) in Either_cortex.iRight ?left:a (Either.Right member_bcde) in let t0 : (('a,'b,'c,'d,'e) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 let injE ?on_proposal ?on_commit ?(a: 'a t option) ?(b:'b t option) ?(c:'c t option) ?(d:'d t option) (e: 'e scalar_or_cortex) : (('a,'b,'c,'d,'e) Sum.t) t = let t1 : (('a,'b,'c,'d,'e) s1) t = let member_de = Either_cortex.iRight ?left:d e in let member_cde = Either_cortex.iRight ?left:c (Either.Right member_de) in let member_bcde = Either_cortex.iRight ?left:b (Either.Right member_cde) in Either_cortex.iRight ?left:a (Either.Right member_bcde) in let t0 : (('a,'b,'c,'d,'e) s0) t = connection ?on_proposal ?on_commit (s0_of_s1) (s1_of_s0) t1 in t0 end let defuse : 'a t -> unit = fun (t_mutexes, t) -> Mutex_group.with_mutex t_mutexes (fun () -> t.Unprotected.no_longer_in_use := true; Container.Queue_with_identifiers.clear (t.Unprotected.on_proposal#as_queue); Container.Queue_with_identifiers.clear (t.Unprotected.on_commit#as_queue); (* Wake up threads waiting on this cortex: *) Condition.broadcast (t.Unprotected.alert_on_commit); ()) module Option_cortex = struct let make ?on_proposal ?on_commit ?none (member_x : 'a t) : ('a option) t = let (x_mutexes, x) = member_x in let mutexes = x_mutexes in let equality = function | None -> ((=)None) | Some a -> let equals_a = (x.Unprotected.equality a) in (function | Some a' -> equals_a a' | None -> false ) in let move_proposal = function | Some _ -> Some (x.Unprotected.get_content ()) | None -> None in let x_bell = Egg.create () in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = (* The initial state is the first component: *) let initial_state = if none = Some () then None else Some (x.Unprotected.get_content ()) in ref initial_state in let get_content () = !content_copy in let rec propose_content v = let v' = match v with | Some a -> let a' = fst (Unprotected.eval_propose a x) in (Some a') | None -> None in content_copy := v'; v' and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_move_proposal_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~move_proposal ~group (member) in let _thd1 = Thread.create (trigger_on x_bell) (member_x) in group) in let () = Egg.wait (x_bell) in group let iNone ?on_proposal ?on_commit (member_x : 'a t) : ('a option) t = make ?on_proposal ?on_commit ~none:() member_x let iSome ?on_proposal ?on_commit (member_x : 'a t) : ('a option) t = make ?on_proposal ?on_commit (*~none:()*) member_x end (* Option_cortex *) let group_array ?on_proposal ?on_commit (members : ('a t) array) : ('a array) t = let size = Array.length members in if size = 0 then invalid_arg "Cortex.group_array: empty array" else let member_list = Array.to_list members in let (mutex_list, xs) = let (ms, xs) = List.split member_list in (ms, Array.of_list xs) in let mutexes = let head = List.hd (mutex_list) in let tail = List.tl (mutex_list) in Mutex_group.group head tail in (* Utility for folding boolean results with the logical operator (&&): *) let and_foldi f vs = let rec loop i = if i>=size then true else if f i vs.(i) then loop (i+1) else false (* stop immediately! *) in loop 0 in (* let or_foldi f vs = let rec loop i = if i>=size then false else if f i vs.(i) then true (* stop immediately! *) else loop (i+1) in loop 0 in*) let equality vs = let equals_v = Array.mapi (fun i v -> xs.(i).Unprotected.equality v) vs in and_foldi (fun i v' -> equals_v.(i) v') in let proposal () = Array.map (fun x -> x.Unprotected.get_content ()) xs in let bells = Array.map (fun x -> Egg.create ()) xs in let group = Mutex_group.with_mutex mutexes (fun () -> let content_copy = ref (proposal ()) in let get_content () = !content_copy in let rec propose_content vs = begin let v'b = Array.mapi (fun i v -> Unprotected.eval_propose v xs.(i)) vs in let v' = (Array.map fst v'b) in content_copy := v'; v' end and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_propose_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~proposal ~group (member) in let _threads = Array.mapi (fun i x -> Thread.create (trigger_on bells.(i)) x) members in group) in let () = Array.iter (Egg.wait) bells in group let sum_array ?on_proposal ?on_commit (members : ('a t) array) : (int * 'a) t = let size = Array.length members in if size = 0 then invalid_arg "Cortex.sum_array: empty array" else let member_list = Array.to_list members in let (mutex_list, xs) = let (ms, xs) = List.split member_list in (ms, Array.of_list xs) in let mutexes = let head = List.hd (mutex_list) in let tail = List.tl (mutex_list) in Mutex_group.group head tail in let equality (i,a) = let equals_a = (xs.(i).Unprotected.equality a) in (fun (j,a') -> i=j (* a sum is disjoint union! *) && equals_a a') in (* At any time, all triggers except one notify changes that will be ignored. Actually, only the trigger of the currently enable component causes a call to the `get_content' of its related component. The others triggers provoke a re-read of the currently enable component... *) let move_proposal (i,_) = (i, xs.(i).Unprotected.get_content ()) in let bells = Array.map (fun x -> Egg.create ()) xs in let group = Mutex_group.with_mutex mutexes (fun () -> (* The initial state is the first component: *) let content_copy = ref (0, xs.(0).Unprotected.get_content ()) in let get_content () = !content_copy in let rec propose_content (i,a) = begin let (a', changed) = Unprotected.eval_propose a xs.(i) in let v' = (i,a') in content_copy := v'; v' end and result = lazy (make ~mutexes ~equality ?on_proposal ?on_commit ~get_content ~propose_content ()) in let (_, group_u) as group = (Lazy.force result) in let membership () = not !(group_u.Unprotected.no_longer_in_use) in let trigger_on (bell) (member) = repeat_move_proposal_to_group_on_member_commit ~signal_me_in_critical_section:bell ~membership ~move_proposal ~group (member) in let _threads = Array.mapi (fun i x -> Thread.create (trigger_on bells.(i)) x) members in group) in let () = Array.iter (Egg.wait) bells in group module Tools = struct let lift_equality_to_option : ('a -> 'b -> bool) -> ('a option -> 'b option -> bool) = fun p -> function | None -> ((=)None) | Some a -> (function None -> false | Some b -> (p a b)) end (* Tools *) module Open = struct type 'a neg = Mutex_group.t -> 'a let return ?(equality:('state -> 'state -> bool) option) ?(on_proposal:('state -> 'state -> 'state) option) ?(on_commit:('state -> 'state -> unit) option) (content:'state) : ('a t) neg = fun mutexes -> let cell = ref content in let get_content () = !cell in let set_content v = (cell := v) in make ~mutexes ?equality ?on_proposal ?on_commit ~get_content ~set_content () let of_unprotected (u : 'a Unprotected.t) : 'a t neg = fun mutexes -> (mutexes, u) let close ?mutexes (f:'a neg) : 'a = let mutexes = match mutexes with | None -> Mutex_group.single () | Some mutexes -> mutexes in (f mutexes) let group_pair ?on_proposal ?on_commit (x1 : 'a t neg) (x2 : 'b t neg) : ('a t * 'b t * ('a * 'b) t) neg = fun mutexes -> let x1 = close ~mutexes x1 in let x2 = close ~mutexes x2 in let group = group_pair ?on_proposal ?on_commit x1 x2 in (x1, x2, group) let group_triple ?on_proposal ?on_commit (x1 : 'a t neg) (x2 : 'b t neg) (x3 : 'c t neg) : ('a t * 'b t * 'c t * ('a * 'b * 'c) t) neg = fun mutexes -> let x1 = close ~mutexes x1 in let x2 = close ~mutexes x2 in let x3 = close ~mutexes x3 in let group = group_triple ?on_proposal ?on_commit x1 x2 x3 in (x1, x2, x3, group) let group_quadruple ?on_proposal ?on_commit (x1 : 'a t neg) (x2 : 'b t neg) (x3 : 'c t neg) (x4 : 'd t neg) : ('a t * 'b t * 'c t * 'd t * ('a * 'b * 'c * 'd) t) neg = fun mutexes -> let x1 = close ~mutexes x1 in let x2 = close ~mutexes x2 in let x3 = close ~mutexes x3 in let x4 = close ~mutexes x4 in let group = group_quadruple ?on_proposal ?on_commit x1 x2 x3 x4 in (x1, x2, x3, x4, group) let group_quintuple ?on_proposal ?on_commit (x1 : 'a t neg) (x2 : 'b t neg) (x3 : 'c t neg) (x4 : 'd t neg) (x5 : 'e t neg) : ('a t * 'b t * 'c t * 'd t * 'e t * ('a * 'b * 'c * 'd * 'e) t) neg = fun mutexes -> let x1 = close ~mutexes x1 in let x2 = close ~mutexes x2 in let x3 = close ~mutexes x3 in let x4 = close ~mutexes x4 in let x5 = close ~mutexes x5 in let group = group_quintuple ?on_proposal ?on_commit x1 x2 x3 x4 x5 in (x1, x2, x3, x4, x5, group) let group_array ?on_proposal ?on_commit (members : ('a t neg) array) : (('a t array) * ('a array) t) neg = fun mutexes -> let members = Array.map (close ~mutexes) members in let group = group_array ?on_proposal ?on_commit members in (members, group) let sum_array ?on_proposal ?on_commit (members : ('a t neg) array) : (('a t array) * (int * 'a) t) neg = fun mutexes -> let members = Array.map (close ~mutexes) members in let sum = sum_array ?on_proposal ?on_commit members in (members, sum) module Product_pair (Prod : sig type ('a,'b) t val prjA : ('a,'b) t -> 'a val prjB : ('a,'b) t -> 'b val make : 'a -> 'b -> ('a,'b) t end) = struct let product_pair ?on_proposal ?on_commit (x1 : 'a t neg) (x2 : 'b t neg) : ('a t * 'b t * (('a,'b) Prod.t) t) neg = fun mutexes -> let x1 = close ~mutexes x1 in let x2 = close ~mutexes x2 in let prod = let module M = Product_pair (Prod) in M.product_pair ?on_proposal ?on_commit x1 x2 in (x1, x2, prod) end (* Redefinition (user version): *) let close f = close f type 'a opn = 'a neg (* Open.lifes. Note that the ~proposal may act on the member which has the same mutexes of the group => mutexes must be recursive! *) let lifes ?on_proposal ?on_commit ~(creator : ?previous:'a -> unit -> 'a t neg) ~(terminal : 'a -> bool) () : ('a option * 'a t) t neg = fun mutexes -> let equality (ao, at) = let au = snd at in let equals_to_ao = Tools.lift_equality_to_option (au.Unprotected.equality) (ao) in let equals_to_at = let p = Unprotected.revno_equality au in fun at' -> p (snd at') in fun (ao', at') -> (equals_to_ao ao') && (equals_to_at at') in let new_member ?previous () = (* same mutexes of the group *) creator ?previous () mutexes in let member = new_member () in let (_, group_u) as group = (*Open.*)return ~equality ?on_proposal ?on_commit (None, member) mutexes in let membership_of member () = let (_, member') = group_u.Unprotected.get_content () in member' == member in let rec (* A new member is proposed when the previous reaches a terminal state: *) guard (_, member) = let (member_m, member_u) = member in let member_state = member_u.Unprotected.get_content () in terminal (member_state) and move_proposal (_, member) = let old_member_state = (snd member).Unprotected.get_content () in let member' = new_member ~previous:old_member_state () in ((Some old_member_state), member') and (* The current thread must be stopped if we are working now on another member. These parameter is redundant because of the usage of ~membership: *) action_and_break_decision_when_accepted s0 s1 s2 = (* s0, s1, s2 = before, proposed, after *) let break = let (_, member0),(_, member2) = s0, s2 in member0 != member2 in break and trigger_on (member) = repeat_move_proposal_to_group_on_member_commit ~membership:(membership_of member) ~guard ~action_and_break_decision_when_accepted ~move_proposal ~group (member) (* end of recursive definition *) in (* Now we start the first thread monitoring the current member: *) let _thd1 = Thread.create (trigger_on) member in (* And we define a callback preventing to set the group with a member already terminated. The `set' operation applied to a group could be very unsafe if we are not sure that the mutexes of the member are contained in the mutexes of the group. We prevent this problem using exclusively the `creator' function to build members. *) let _thunk_id = let mutexes_and_members_are_the_same (_, member0) (_, member1) : bool * bool = let (member0_mutexes, member0_unp) = member0 in let (member1_mutexes, member1_unp) = member1 in (member0_mutexes = member1_mutexes), (member0_unp == member1_unp) in on_proposal_append (group) (fun s0 s1 -> let s2 = if guard s1 then move_proposal s1 else s1 in let same_mutexes, same_members = mutexes_and_members_are_the_same s0 s2 in (* Proposal with distinct mutexes are forbidden: *) if not (same_mutexes) then s0 else (* Start a monitoring thread if a new member replace the previous: *) let () = if same_members then () else begin let member' = snd s2 in let _thd = Thread.create (trigger_on) member' in () end in s2) in group end (* Open *) type 'a u = 'a t Open.neg (* Note that the ~proposal may act on the member which has the same mutexes of the group => mutexes must be recursive! *) let lifes ?on_proposal ?on_commit ~(creator : ?previous:'a -> unit -> 'a u) ~(terminal : 'a -> bool) () : ('a option * 'a t) t = let mutexes = Mutex_group.single () in Open.lifes ?on_proposal ?on_commit ~creator ~terminal () mutexes module Object = struct class type ['a] public_interface = object method cortex_t : 'a t method eval : 'b 'c. ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'c * bool method get : ?guard:('a -> bool) -> unit -> 'a method set : ?guard:('a -> bool) -> 'a -> unit method propose : ?guard:('a -> bool) -> 'a -> 'a * bool method move : ?guard:('a -> bool) -> ('a -> 'a) -> 'a * bool method async : < set : ?guard:('a -> bool) -> 'a -> unit; move : ?guard:('a -> bool) -> ('a -> 'a) -> unit; > end class type ['a] private_interface = object method private cortex_t : 'a t method private eval : 'b 'c. ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'c * bool method private get : ?guard:('a -> bool) -> unit -> 'a method private set : ?guard:('a -> bool) -> 'a -> unit method private propose : ?guard:('a -> bool) -> 'a -> 'a * bool method private move : ?guard:('a -> bool) -> ('a -> 'a) -> 'a * bool method private async : < set : ?guard:('a -> bool) -> 'a -> unit; move : ?guard:('a -> bool) -> ('a -> 'a) -> unit; > end class ['a] with_public_interface (x:'a t) = object method cortex_t : 'a t = x method eval : 'b 'c. ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'c * bool = fun ?guard f b -> eval ?guard f b x method get : ?guard:('a -> bool) -> unit -> 'a = fun ?guard () -> get ?guard x method set : ?guard:('a -> bool) -> 'a -> unit = fun ?guard v -> set ?guard x v method propose : ?guard:('a -> bool) -> 'a -> 'a * bool = fun ?guard v -> propose ?guard x v method move : ?guard:('a -> bool) -> ('a -> 'a) -> 'a * bool = fun ?guard f -> move ?guard x f method async = object method set : ?guard:('a -> bool) -> 'a -> unit = fun ?guard v -> Async.set ?guard x v method move : ?guard:('a -> bool) -> ('a -> 'a) -> unit = fun ?guard f -> Async.move ?guard x f end end class ['a] with_private_interface (x:'a t) = object method private cortex_t : 'a t = x method private eval : 'b 'c. ?guard:('a -> bool) -> ('a -> 'b -> 'a * ('a -> 'c)) -> 'b -> 'c * bool = fun ?guard f b -> eval ?guard f b x method private get : ?guard:('a -> bool) -> unit -> 'a = fun ?guard () -> get ?guard x method private set : ?guard:('a -> bool) -> 'a -> unit = fun ?guard v -> set ?guard x v method private propose : ?guard:('a -> bool) -> 'a -> 'a * bool = fun ?guard v -> propose ?guard x v method private move : ?guard:('a -> bool) -> ('a -> 'a) -> 'a * bool = fun ?guard f -> move ?guard x f method private async = object method set : ?guard:('a -> bool) -> 'a -> unit = fun ?guard v -> Async.set ?guard x v method move : ?guard:('a -> bool) -> ('a -> 'a) -> unit = fun ?guard f -> Async.move ?guard x f end end let with_public_interface : 'a t -> 'a public_interface = fun x -> new with_public_interface x let with_private_interface : 'a t -> 'a private_interface = fun x -> new with_private_interface x end (* Object *) IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Make_Examples (Void:sig end) = struct module Example1 = struct let x = return 42 ;; let y = return 10 ;; let z = group_pair x y ;; let w = Either_cortex.iLeft ~right:y (Either.Right x) ;; let s = sum_array [| x; x; y; y |] ;; propose x 5 ;; (* Uncomment the following lines in order to follow the stabilization of resistences: *) on_commit_append x (fun x0 x1 -> Printf.kfprintf flush stderr "x changed from %d to %d\n" x0 x1) ;; on_proposal_append x (fun x0 x1 -> Printf.kfprintf flush stderr "proposed to change x from %d to %d\n" x0 x1; Thread.delay 0.5; x1) ;; on_proposal_append y (fun y0 y1 -> Printf.kfprintf flush stderr "proposed to change y from %d to %d\n" y0 y1; Thread.delay 0.5; y1) ;; on_proposal_append z (fun (x0,y0) (x1,y1) -> Printf.kfprintf flush stderr "proposed to change z from (%d,%d) to (%d,%d)\n" x0 y0 x1 y1; Thread.delay 0.5; (x1,y1)) ;; let even x = (x mod 2 = 0) ;; let must_be_natural_or_abs = fun _x0 x1 -> if x1<0 then (abs x1) else x1 ;; let must_be_odd_or_decrement = fun _x0 x1 -> if even x1 then x1-1 else x1 ;; let must_be_even_or_increment = fun _x0 x1 -> if even x1 then x1 else x1+1 ;; let snd_must_be_double_of_fst_or_move_away = fun (x0,y0) ((x1,y1) as ok) -> if (y1 = 2 * x1) then ok else if (x1 <> x0) then (x1, x1*2) else let y2 = if (even y1) then y1 else y1+1 in let x2 = y2/2 in (* Prevent cycles: *) if (x0 = x2 || y0 = y2) then (x0,y0) else (x2,y2) ;; (* x must be natural and odd: *) on_proposal_append x (must_be_natural_or_abs) ;; on_proposal_append x (must_be_odd_or_decrement) ;; (* y must be natural and even: *) on_proposal_append y (must_be_natural_or_abs) ;; on_proposal_append y (must_be_even_or_increment) ;; (* z = (x,y) requires that y will be the double of x *) on_proposal_append z (snd_must_be_double_of_fst_or_move_away) ;; (* get z ;; : int * int = (5, 10) get w ;; : (int, int) Either.t = Either.Left 42 propose x 50 ;; : int * bool = (51, true) get z ;; : int * int = (51, 102) propose x 52 ;; : int * bool = (53, true) get z ;; : int * int = (53, 106) propose y 107 ;; : int * bool = (108, true) get z ;; : int * int = (55, 110) *) module Triad = struct type ('a,'b,'c) t = | Apollo of 'a (* god of the sun, culture and music *) | Athena of 'b (* goddess of war and intellect *) | Zeus of 'c (* king of the gods *) let injA a = Apollo a let injB b = Athena b let injC c = Zeus c let case t f1 f2 f3 = match t with | Apollo a -> f1 a | Athena b -> f2 b | Zeus c -> f3 c end;; (* Triad *) module Triad_cortex = Sum_triple (Triad) ;; let apollo ?zeus ?athena = Triad_cortex.injA ?b:athena ?c:zeus ;; let athena ?zeus ?apollo = Triad_cortex.injB ?a:apollo ?c:zeus ;; let zeus ?athena ?apollo = Triad_cortex.injC ?a:apollo ?b:athena ;; let t = zeus ~athena:x ~apollo:y (scalar "ciao") ;; (* get t ;; : (int, int, string) Triad.t = Triad.Zeus "ciao" propose t (Triad.Apollo 100) ;; : (int, int, string) Triad.t * bool = (Triad.Apollo 100, true) <===================== PROBLEMA DELLA connection (indipendente dal target)!! get t ;; : (int, int, string) Triad.t = Triad.Apollo 98 *) end (* module Example1 *) module Example2 = struct let x = lifes ~creator:(fun ?previous () -> Open.return 42) ~terminal:((>=)0) () ;; (* val x : (int option * int Cortex.t) Cortex.t = *) let look x = get (snd (get x)) ;; (* val look : ('a * 'b Cortex.t) Cortex.t -> 'b = *) let member x = snd (get x) ;; (* val member : ('a * 'b Cortex.t) Cortex.t -> 'b Cortex.t = *) let y = member x ;; (* val y : int Cortex.t = *) get y ;; (* - : int = 42 *) set y 10;; (* - : unit = () *) look x ;; (* - : int = 10 *) set y 20;; (* - : unit = () *) look x ;; (* - : int = 20 *) set y 0;; (* - : unit = () *) look x ;; (* - : int = 42 *) get x ;; (* - : int option * int Cortex.t = (Some 0, ) *) set y (-11);; (* - : unit = () *) get x ;; (* - : int option * int Cortex.t = (Some 0, ) *) look x ;; (* - : int = 42 *) let z = return 33 ;; (* val z : int Cortex.t = *) propose x (None, z) ;; (* - : (int option * int Cortex.t) * bool = ((Some 0, ), false) *) propose x (None, y) ;; (* - : (int option * int Cortex.t) * bool = ((Some (-11), ), true) *) look x;; (* - : int = 42 *) set y 11 ;; (* - : unit = () *) propose x (None, y) ;; (* - : (int option * int Cortex.t) * bool = ((None, ), true) *) look x;; (* - : int = 11 *) set y (-11) ;; look x;; (* - : int = 42 *) end end (* functor Make_Examples *) ENDIF (* Renaming: *) type ('a,'b) either = ('a,'b) Either.t module Either = Either_cortex;; module Option = Option_cortex;; ocamlbricks-0.90+bzr456.orig/STRUCTURES/option.mli0000644000175000017500000000616513175721005020471 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Operations on type ['a option]. *) type 'a t = 'a option (** Extract the encapsulated value. If the argument is [None], the optional [?fallback] is called. By default [fallback] is set to [fun ()->failwith "Option.extract"].*) val extract : ?failwith_msg:string -> ?fallback:(unit -> 'a) -> 'a option -> 'a val extract_or : 'a option -> 'a -> 'a val extract_or_force : 'a option -> 'a Lazy.t -> 'a val extract_from_list : ?acc:'a list -> 'a option list -> 'a list val extract_map_or : 'a option -> ('a -> 'b) -> 'b -> 'b val map : ('a -> 'b) -> 'a option -> 'b option val bind : 'a option -> ('a -> 'b option) -> 'b option val return : 'a -> 'a option val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option val bind2 : 'a option -> 'b option -> ('a -> 'b -> 'c option) -> 'c option val join : 'a option option -> 'a option val iter : ('a -> unit) -> 'a option -> unit val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit val filter : ('a -> bool) -> 'a option -> 'a option val apply_or_catch : ?fallback:(exn -> 'a -> unit) -> ('a -> 'b) -> 'a -> 'b option val of_bool : bool -> unit option val to_bool : 'a option -> bool val to_list : 'a option -> 'a list val split : ('a * 'b) option -> 'a option * 'b option val split3 : ('a * 'b * 'c) option -> 'a option * 'b option * 'c option val split4 : ('a * 'b * 'c * 'd) option -> 'a option * 'b option * 'c option * 'd option val split5 : ('a * 'b * 'c * 'd * 'e) option -> 'a option * 'b option * 'c option * 'd option * 'e option val combine : 'a option -> 'b option -> ('a * 'b) option val combine3 : 'a option -> 'b option -> 'c option -> ('a * 'b * 'c) option val combine4 : 'a option -> 'b option -> 'c option -> 'd option -> ('a * 'b * 'c * 'd) option val combine5 : 'a option -> 'b option -> 'c option -> 'd option -> 'e option -> ('a * 'b * 'c * 'd * 'e) option (* Printing *) val printf : ?none:string -> ?frame:(string -> string, unit, string) format -> ('a -> string, unit, string) format -> 'a option -> unit val eprintf : ?none:string -> ?frame:(string -> string, unit, string) format -> ('a -> string, unit, string) format -> 'a option -> unit val sprintf : ?none:string -> ?frame:(string -> string, unit, string) format -> ('a -> string, unit, string) format -> 'a option -> string val to_string : ?none:string -> ?frame:(string -> string, unit, string) format -> ?a:('a -> string) -> 'a option -> string ocamlbricks-0.90+bzr456.orig/STRUCTURES/hashmap.mli0000644000175000017500000000347013175721005020576 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Polymorphic {e unbounded} maps (environments). *) type ('a, 'b) t val make : ?size:int -> unit -> ('a, 'b) t val lookup : ('a, 'b) t -> 'a -> 'b val mem : ('a, 'b) t -> 'a -> 'b -> bool val memq : ('a, 'b) t -> 'a -> 'b -> bool val bound : ('a, 'b) t -> 'a -> bool val add : ('a, 'b) t -> 'a -> 'b -> unit val add_list : ('a, 'b) t -> ('a * 'b) list -> unit val replace : ('a, 'b) t -> 'a -> 'b -> unit val remove : ('a, 'b) t -> 'a -> unit val update : ('a, 'b) t -> ('a, 'b) t -> unit val to_list : ('a, 'b) t -> ('a * 'b) list val of_list : ?size:int -> ('a * 'b) list -> ('a, 'b) t (** {2 Object-oriented interface} *) class ['a, 'b] hashmap : ?size:int -> unit -> object method add : 'a -> 'b -> unit method add_list : ('a * 'b) list -> unit method bound : 'a -> bool method get : ('a, 'b) Hashtbl.t method lookup : 'a -> 'b method mem : 'a -> 'b -> bool method memq : 'a -> 'b -> bool method remove : 'a -> unit method replace : 'a -> 'b -> unit method to_list : ('a * 'b) list end ocamlbricks-0.90+bzr456.orig/STRUCTURES/lazy_perishable.ml0000644000175000017500000000310713175721005022156 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2015 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** Lazy values with a lifetime. When the delay is expired, the value is recalculated. *) type 'a t = ('a Thunk.t) * (('a status) ref) and 'a status = ('a * date) option (* None => not calculated, Some (y, d) => y calculated at the date d *) and date = float (* --- *) and lifetime = seconds and seconds = float let create (thunk) (lifetime) = let already_called = ref None in let thunk = fun () -> let now = Unix.gettimeofday () in match !already_called with | Some (y, date) when (now -. date) < lifetime -> y | _ -> begin let y = thunk () in already_called := Some (y, now); (* memoise *) y end in (thunk, already_called) let force (t, _) = t () let set_expired (t, s) = (s := None) ocamlbricks-0.90+bzr456.orig/STRUCTURES/string_queue.mli0000644000175000017500000000325613175721005021671 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Thread safe, efficient concatenation of string queues. *) type t val create : ?block_size:int -> unit -> t (** {2 Writers' tools} *) (** The queue is released by default for all operations. The user could request the non-releasing setting the optional parameter [~release] to [false]. *) val append_from_descr : ?release:bool -> t -> Unix.file_descr -> unit val from_descr : ?release:bool -> ?block_size:int -> Unix.file_descr -> t val from_file : ?release:bool -> ?block_size:int -> string -> t val from_channel : ?release:bool -> ?block_size:int -> in_channel -> t (** {2 Readers' tools} *) type blit_function = string -> int -> string -> int -> int -> unit val concat : ?blit:blit_function -> t -> string (** {2 Thread_unsafe versions} *) module Thread_unsafe : sig val append_from_descr : ?release:bool -> t -> Unix.file_descr -> unit val concat : ?blit:blit_function -> t -> string end ocamlbricks-0.90+bzr456.orig/STRUCTURES/bit.ml0000644000175000017500000000670613175721005017567 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* Example: first_powers_of_2 ~length:9 = [256; 128; 64; 32; 16; 8; 4; 2; 1] *) let first_powers_of_2 ~length = let rec loop acc j i = if i=length then acc else loop (j::acc) (j*2) (i+1) in loop [] 1 0 ;; (* Example: first_powers_of_2_until ~covered_int:89 = [64; 32; 16; 8; 4; 2; 1] *) let first_powers_of_2_until ~covered_int = let rec loop acc j i = if j>covered_int then acc else loop (j::acc) (j*2) (i+1) in loop [] 1 0 ;; (** Convert an integer (supposed unsigned) in a list of bits, where each bit is represented as a boolean value. The list starts with the more relevant bit and ends with the less relevant. The length of the list is automatically minimal, hence the first element of the result will always be [true] (for inputs greater than [0]). Setting the optional parameter [?length] to a value greater than this minimal value, the {e head} of the list will be completed by zeros ([false]). On the other hand, setting [?length] to a value lesser than the minimal, only the last (less relevant) bits will be returned. {b Examples}: {[# Bit.bits_as_booleans_of_int 34 ;; : bool list = [true; false; false; false; true; false] # Bit.bits_as_booleans_of_int ~length:8 34 ;; : bool list = [false; false; true; false; false; false; true; false] # Bit.bits_as_booleans_of_int ~length:5 34 ;; : bool list = [false; false; false; true; false] ]}*) let bits_as_booleans_of_int ?length i = let powers = match length with | None -> first_powers_of_2_until ~covered_int:i | Some length -> first_powers_of_2 ~length in List.rev (snd (List.fold_left (fun (r,l) x -> ((r mod x),((r/x)=1)::l)) (i,[]) powers)) (** The inverse of {!Bit.bits_as_booleans_of_int}: convert a list of booleans in an unsigned integer. *) let int_of_bits_as_booleans (xs:bool list) = let powers = first_powers_of_2 ~length:(List.length xs) in let ys = List.combine xs powers in List.fold_left (fun acc (x,y) -> acc + if x then y else 0) 0 ys (** Similar to {!Bit.bits_as_booleans_of_int}, but the result is a list of integers (in [{0,1}]). {b Examples}: {[# Bit.bits_as_integers_of_int 34 ;; : int list = [1; 0; 0; 0; 1; 0] # Bit.bits_as_integers_of_int ~length:8 34 ;; : int list = [0; 0; 1; 0; 0; 0; 1; 0] # Bit.bits_as_integers_of_int ~length:5 34 ;; : int list = [0; 0; 0; 1; 0] ]} *) let bits_as_integers_of_int ?length i = List.map (function false->0|true->1) (bits_as_booleans_of_int ?length i) (** The inverse of {!Bit.bits_as_integers_of_int}. *) let int_of_bits_as_integers (xs:int list) = int_of_bits_as_booleans (List.map (function 0->false | 1->true | _ -> invalid_arg "Bit.int_of_bits_as_integers") xs) ocamlbricks-0.90+bzr456.orig/STRUCTURES/cortex_lib.mli0000644000175000017500000001213013175721005021300 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Common recurrent cortex instances (process, service,..). *) module Process : sig type program = string type arguments = string list type pid = int type birthtime = float (* since 00:00:00 GMT, Jan. 1, 1970, in seconds *) type age = float (* duration, in seconds *) type exit_code = int type signal_name = string type mrproper = unit -> unit type options type tuning = unit -> options val make_options : ?enrich:options -> ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> unit -> options module State : sig type running_state = Running | Suspended type t = | Planned of tuning * program * arguments | Started of program * birthtime * pid * mrproper * running_state | Terminated of program * age * pid * (signal_name, exit_code) Either.t val equality : t -> t -> bool val is_planned : t -> bool val is_started : t -> bool val is_suspended : t -> bool val is_running : t -> bool val is_terminated : t -> bool val is_terminated_and_has_been_really_executed : t -> bool val is_terminated_aged_at_least : seconds:float -> t -> bool val birthtime : t -> float option val age : t -> float option end (* Process.State *) type t = State.t Cortex.t type u = State.t Cortex.u (* open cortex *) val plan : ?tuning:(unit -> options) -> program -> arguments -> t module Open : sig val plan : ?tuning:(unit -> options) -> program -> arguments -> u end val start : t -> State.t * bool val suspend : ?nohang:unit -> t -> State.t * bool val resume : ?nohang:unit -> t -> State.t * bool val terminate : ?nohang:unit -> t -> State.t * bool class c : ?tuning:(unit -> options) -> program -> arguments -> object inherit [State.t] Cortex.Object.with_private_interface method start : unit -> State.t * bool method suspend : ?nohang:unit -> unit -> State.t * bool method resume : ?nohang:unit -> unit -> State.t * bool method terminate : ?nohang:unit -> unit -> State.t * bool end end module Service : sig type t = (Process.State.t option * Process.t) Cortex.t val plan : ?tuning:Process.tuning -> Process.program -> Process.arguments -> t val start : t -> Process.State.t * bool val previous_status : t -> Process.State.t option val previous_really_executed : t -> bool val previous_age : t -> float option val previous_aged_at_least : seconds:float -> t -> bool val status : t -> Process.State.t val suspend : t -> Process.State.t * bool val resume : ?nohang:unit -> t -> Process.State.t * bool val stop : ?nohang:unit -> t -> Process.State.t * bool val restart : t -> Process.State.t * bool class c : ?tuning:Process.tuning -> Process.program -> Process.arguments -> object inherit [Process.State.t option * Process.t] Cortex.Object.with_private_interface method start : unit -> Process.State.t * bool method previous_status : unit -> Process.State.t option method previous_really_executed : unit -> bool method previous_age : unit -> float option method previous_aged_at_least : seconds:float -> bool method status : unit -> Process.State.t method suspend : unit -> Process.State.t * bool method resume : ?nohang:unit -> unit -> Process.State.t * bool method stop : ?nohang:unit -> unit -> Process.State.t * bool method restart : unit -> Process.State.t * bool end end (* 1-position communication channels: *) module Channel : sig (* The channel may be empty or it may contain a message for someone *) type 'a t = ('a option) Cortex.t val return : ?equality:('a -> 'a -> bool) -> ?on_proposal:('a option -> 'a option -> 'a option) -> ?on_commit:('a option -> 'a option -> unit) -> ?init:'a -> unit -> 'a t val receive : 'a t -> 'a val send : 'a t -> 'a -> bool (* success/failure of sending *) end (* Channel *) module Clock : sig type t = int Cortex.t val make : ?init:int -> ?limit:int -> ?delay:float -> unit -> t end ocamlbricks-0.90+bzr456.orig/STRUCTURES/cache.ml0000644000175000017500000000252513175721005020047 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** The result is the thunk managing the cache memory. *) let optimize ~(revision:'t->int) (f:'t->'a) (t:'t) = let r = ref 0 in let y = ref None in let cache_fault revision = (* (Printf.kfprintf flush stderr "Cache fault on revision %d\n" revision); *) let result = f t in (y := Some result); (r := revision); result in let thunk () = let revision = revision t in if !r = revision then match !y with | Some y -> y | None -> cache_fault revision else cache_fault revision in thunk ocamlbricks-0.90+bzr456.orig/STRUCTURES/either.ml0000644000175000017500000000433213175721005020262 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) type ('a,'b) t = Left of 'a | Right of 'b type ('a,'b) either = ('a,'b) t let get_right = function | Right b -> b | Left _ -> invalid_arg "Either.right" let get_left = function | Left a -> a | Right _ -> invalid_arg "Either.left" let left x = Left x let right x = Right x let extract ?(failwith_msg="Either.extract") ?(fallback=(fun _ -> failwith failwith_msg)) = function | Left a -> fallback a | Right b -> b let extract_or x y = match x with | Left a -> y | Right b -> b let extract_or_force x y = match x with | Left a -> Lazy.force y | Right b -> b let extract_from_list ?(acc=[]) xs = let rec loop = function | [] -> acc | (Left _)::xs -> (loop xs) | (Right b)::xs -> b::(loop xs) in loop xs let map (f:'a->'b) = function | Right b -> Right (f b) | Left a -> Left a let bind x f = match x with | Right b -> (f b) | Left a -> Left a let return b = Right b let iter f = function | Right b -> (f b) | _ -> () let apply_or_catch f x = try Right (f x) with e -> Left e let of_bool = function | false -> Left () | true -> Right () let to_bool = function | Left _ -> false | Right _ -> true let list_of = function Left _ -> [] | Right b -> [b] let to_string ?(a=fun _ -> "_") ?(b=fun _ -> "_") = function | Left x -> "Left "^(a x) | Right x -> "Right "^(b x) module Bifunctor = struct let map : ('a0 -> 'a1) -> ('b0 -> 'b1) -> ('a0,'b0) t -> ('a1,'b1) t = fun f1 f2 -> function | Left a -> Left (f1 a) | Right b -> Right (f2 b) end ocamlbricks-0.90+bzr456.orig/STRUCTURES/memo.ml0000644000175000017500000000637613175721005017751 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007-2011 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) module Log = Ocamlbricks_log (** The default size of for hash tables. *) let default_size = 251;; (** Memoize a function. *) let memoize_and_get_table ?trace_faults ?trace_success ?(size=default_size) f = let ht = Hashtbl.create size in let calls, success = (ref 0), (ref 0) in let f' = match trace_faults, trace_success with | None, None -> (function x -> try Hashtbl.find ht x with Not_found -> begin let y = f x in let () = Hashtbl.add ht x y in y end) | (Some ()), None -> (function x -> let () = incr calls in try let result = Hashtbl.find ht x in let () = incr success in result with Not_found -> begin Log.printf2 "Memo.memoize: cache fault for hash key %d (cumulated faults %4.1f%%).\n" (Hashtbl.hash x) (PervasivesExtra.percentage_fraction ~decimals:1 (!calls - !success) !calls); let y = f x in let () = Hashtbl.add ht x y in y end) | None, (Some ()) -> (function x -> let () = incr calls in try let result = Hashtbl.find ht x in let () = incr success in let () = Log.printf2 "Memo.memoize: success for hash key %d (cumulated success %4.1f%%).\n" (Hashtbl.hash x) (PervasivesExtra.percentage_fraction ~decimals:1 !success !calls) in result with Not_found -> begin let y = f x in let () = Hashtbl.add ht x y in y end) | (Some ()), (Some ()) -> (function x -> let () = incr calls in try let result = Hashtbl.find ht x in let () = incr success in let () = Log.printf2 "Memo.memoize: success for hash key %d (cumulated success %4.1f%%).\n" (Hashtbl.hash x) (PervasivesExtra.percentage_fraction ~decimals:1 !success !calls) in result with Not_found -> begin Log.printf2 "Memo.memoize: cache fault for hash key %d (cumulated faults %4.1f%%).\n" (Hashtbl.hash x) (PervasivesExtra.percentage_fraction ~decimals:1 (!calls - !success) !calls); let y = f x in let () = Hashtbl.add ht x y in y end) in (f', ht) let memoize ?trace_faults ?trace_success ?size f = fst (memoize_and_get_table ?trace_faults ?trace_success ?size f) ocamlbricks-0.90+bzr456.orig/STRUCTURES/stateful_modules.mli0000644000175000017500000000366113175721005022536 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) module type Type = sig type t val name:string option end module Variable : functor (Type : Type) -> sig type t = Type.t val get : unit -> t option val extract : unit -> t val set : t -> unit val unset : unit -> unit val lazy_set: t Lazy.t -> unit val content : t Lazy.t option ref end module Thread_shared_variable : functor (Type : Type) -> sig type t = Type.t val get : unit -> t option val extract : unit -> t val set : t -> unit val lazy_set: t Lazy.t -> unit val unset : unit -> unit val apply_with_mutex : ('a -> 'b) -> 'a -> 'b val lock : unit -> unit val unlock : unit -> unit end module type Type_with_init = sig type t val name : string option val init : unit -> t end module Process_private_thread_shared_variable : functor (Type : Type_with_init) -> sig type t = Type.t val get : unit -> t option val extract : unit -> t val set : t -> unit val lazy_set: t Lazy.t -> unit val unset : unit -> unit val apply_with_mutex : ('a -> 'b) -> 'a -> 'b val lock : unit -> unit val unlock : unit -> unit end ocamlbricks-0.90+bzr456.orig/STRUCTURES/egg.ml0000644000175000017500000000525013175721005017544 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type 'a t = { mutable barrier : bool ; condition : Condition.t ; mutex : Mutex.t ; mutable egg : 'a option ; mutable release_power_available : bool ; } (** Create an egg structure. *) let create () = { barrier = true ; condition = Condition.create () ; mutex = Mutex.create () ; egg = None ; release_power_available = true ; } (* Included here from MutexExtra for efficiency. *) let with_mutex mutex thunk = Mutex.lock mutex; try let result = thunk () in Mutex.unlock mutex; result with e -> begin Mutex.unlock mutex; (Printf.eprintf "Semaphore.with_mutex: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)); raise e; end (** Wait for the egg. If the egg is ready, return its value immediately. *) let wait t = with_mutex t.mutex (fun () -> begin while t.barrier do (Condition.wait t.condition t.mutex) done; match t.egg with | Some x -> x | None -> assert false end) (** Non-blocking wait: get the current optional value of the egg. *) let taste t = with_mutex t.mutex (fun () -> t.egg) (** [release t v] release the value [v] (the egg) for the structure [t]. Broadcast all pending readers. Future readers will get the egg immediately without blocking. This call is typically performed once forever. *) let release t v = with_mutex t.mutex (fun () -> begin (t.barrier <- false); (t.egg <- Some v); (Condition.broadcast t.condition); end) (** Acquire the power to release the egg, i.e. the power to be {e the} writer. *) let acquire_release_power t = with_mutex t.mutex (fun () -> if t.barrier && t.release_power_available then begin t.release_power_available <- false; true end else false) ocamlbricks-0.90+bzr456.orig/STRUCTURES/ipv6.mli0000644000175000017500000000455113175721005020042 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** IPv6 parsing and printing. *) (** The internal representation of an ipv6 address. *) type t = int array (** The integer implicitely representing the netmask. Admissible values are in the range [0..128]. *) type cidr = int (** The internal representation of an ipv6 configuration, i.e. a pair [
/]. *) type config = t * cidr val of_string : string -> t val to_string : ?uncompress:unit -> t -> string val config_of_string : string -> config val string_of_config : ?uncompress:unit -> config -> string type ipcalc_result = < ip : t; (** The given address *) cidr : int; (** The given cidr *) config : t * int; (** The given address,cidr *) netmask : t; (** The derived netmask *) network : t; (** The derived network address *) hostmin : t; (** Host minimal address in this network *) hostmax : t; (** Host maximal address in this network *) contains : t -> bool; (** Does the network contain this address? *) print : unit; (** Print all given and derived informations *) (** String conversions: *) to_string : < ip : string; cidr : string; config : string; netmask : string; network : string; hostmax : string; hostmin : string; > > val ipcalc : t -> cidr -> ipcalc_result module String : sig val is_valid_ipv6 : string -> bool val is_valid_config : string -> bool val ipcalc : config:string -> < ip : string; cidr : string; netmask : string; network : string; hostmin : string; hostmax : string; contains : ip:string -> bool; print : unit; > end ocamlbricks-0.90+bzr456.orig/STRUCTURES/cloakroom.mli0000644000175000017500000000367713175721005021154 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** A container where elements may be left and succesively removed using their associated ticket. Any type of elements are allowed, even functions. These elements are considered equivalent in the same way as the standard module [Hashtbl] consider keys equivalent. Adding and removing elements are O(log n), itering and folding (by id) are linear O(n) as for simple lists. Furthermore, elements are found in O(log n) comparing integer keys. *) type 'a t type id = int val create : ?size:int -> unit -> 'a t val add : 'a t -> 'a -> id val remove : 'a t -> id -> bool val mem : 'a t -> id -> bool val length : 'a t -> int val revision : 'a t -> int val iter : (id -> 'a -> unit ) -> 'a t -> unit val fold : (id -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val to_list : 'a t -> 'a list val to_assoc_list : 'a t -> (id * 'a) list val of_list : 'a list -> 'a t * (id list) module Cached : sig val to_list : 'a t -> unit -> 'a list val to_assoc_list : 'a t -> unit -> (id * 'a) list end module Hetero : sig type t type id = int val create : ?size:int -> unit -> t val add : t -> 'a -> id val find : t -> id -> 'a val remove : t -> id -> bool val mem : t -> id -> bool val length : t -> int end ocamlbricks-0.90+bzr456.orig/STRUCTURES/ipv4.ml0000644000175000017500000002161213175721005017664 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../STRUCTURES/ipv4.mli" ;; (** Example: [23 -> (255,255,254,0)] *) let netmask_of_cidr x = let invalid_arg () = invalid_arg (Printf.sprintf "Ipv4.netmask_of_cidr: netmask in CIDR notation %d out of the range 0..32" x) in (* Return a byte from a cidr in the range [0..8]. Example: 1 -> 128 *) let byte_of_cidr x = let rec loop c = if c=0. then 0. else (loop (c -. 1.)) +. (2. ** (8. -. c)) in int_of_float (loop (float_of_int x)) in if not ((x>=0) && (x<=32)) then invalid_arg () else let rec loop i acc c = if i > 4 then acc else if c>8 then (loop (i+1) (255::acc) (c-8)) else (loop (i+1) ((byte_of_cidr c)::acc) 0) in match (loop 1 [] x) with | [n4;n3;n2;n1] -> (n1,n2,n3,n4) | _ -> assert false (** Example: [(255,255,254,0) -> 23] *) let cidr_of_netmask (n1,n2,n3,n4) = let invalid_arg () = invalid_arg (Printf.sprintf "Ipv4.cidr_of_netmask: ill-formed netmask %i.%i.%i.%i" n1 n2 n3 n4) in (* Return a cidr in the range [0..8] from a byte. Example: 128 -> 1. *) let cidr_of_byte = function | 0 -> 0 | 128 -> 1 | 192 -> 2 | 224 -> 3 | 240 -> 4 | 248 -> 5 | 252 -> 6 | 254 -> 7 | 255 -> 8 | x -> invalid_arg () in let xs = List.map cidr_of_byte [n1;n2;n3;n4] in match xs with | [_;0;0;0] | [8;_;0;0] | [8;8;_;0] | [8;8;8;_] -> List.fold_left (+) 0 xs | _ -> invalid_arg () (** Example: ["255.255.248.0" -> (255, 255, 248, 0)] *) let netmask_of_string s = let invalid_arg () = invalid_arg (Printf.sprintf "Ipv4.netmask_of_string: ill-formed netmask %s" s) in try begin let netmask = Scanf.sscanf s "%i.%i.%i.%i%s" (fun b1 b2 b3 b4 r -> (assert (r="")); (b1, b2, b3, b4)) in let _ = cidr_of_netmask netmask in (* verify *) netmask end with _ -> invalid_arg () (** Example: ["192.168.1.42" -> (192,168,1,42)] *) let of_string s = let invalid_arg () = invalid_arg (Printf.sprintf "Ipv4.of_string: ill-formed ipv4 address %s" s) in (** A valid ipv4 has each byte in the range [0..255]. *) let is_valid (b1,b2,b3,b4) = List.for_all (fun x->(x>=0) && (x<=255)) [b1; b2; b3; b4] in try let result = Scanf.sscanf s "%i.%i.%i.%i%s" (fun b1 b2 b3 b4 r -> (assert (r="")); (b1, b2, b3, b4)) in if is_valid result then result else invalid_arg () with _ -> invalid_arg () (** Example: ["192.168.1.42" -> (192,168,1,42)] *) let to_string (b1, b2, b3, b4) = Printf.sprintf "%i.%i.%i.%i" b1 b2 b3 b4 let string_of_config ((b1, b2, b3, b4), cidr) = Printf.sprintf "%i.%i.%i.%i/%i" b1 b2 b3 b4 cidr let string_of_socket ((b1, b2, b3, b4), port) = Printf.sprintf "%i.%i.%i.%i:%i" b1 b2 b3 b4 port (** Convert a string in the form ["xx.xx.xx.xx/"] into its internal representation. *) let config_of_string (config:string) = match Option.apply_or_catch (Scanf.sscanf config "%s@/%i%s") (fun s i r -> (assert (r="")); (s,i)) with | None -> invalid_arg ("Ipv4.config_of_string: ill-formed
/ : "^config) | Some (s, cidr) -> if cidr < 0 || cidr > 32 then invalid_arg ("Ipv4.config_of_string: invalid cidr: "^(string_of_int cidr)) else begin match Option.apply_or_catch of_string s with | None -> invalid_arg ("Ipv4.config_of_string: ill-formed address: "^s) | Some t -> (t, cidr) end (** Convert a string in the form ["xx.xx.xx.xx:"] into its internal representation. *) let socket_of_string (socket:string) = match Option.apply_or_catch (Scanf.sscanf socket "%s@:%i%s") (fun s i r -> (assert (r="")); (s,i)) with | None -> invalid_arg ("Ipv4.socket_of_string: ill-formed
: : "^socket) | Some (s, port) -> if port < 0 || port > 65535 then invalid_arg ("Ipv4.socket_of_string: invalid port number: "^(string_of_int port)) else begin match Option.apply_or_catch of_string s with | None -> invalid_arg ("Ipv4.socket_of_string: ill-formed address: "^s) | Some t -> (t, port) end (** Try to complete an Ipv4 address using historical classes (as performed for instance by the Unix command `ifconfig') *) let to_config ((b1, b2, b3, b4) as t) : config option = let b5 = if b1 < 128 then Some 8 (* class A *) else if b1 < 192 then Some 16 (* class B *) else if b1 < 224 then Some 24 (* class C *) else None in Option.map (fun b5 -> (t,b5)) b5 (** Try to import a string as config or simple address (when the CIDR is not specified neither deductible). *) let import (s:string) : (t, config) Either.t option = try begin let config = config_of_string s in Some (Either.Right config) end with _ -> try begin let t = of_string s in match to_config t with | Some config -> Some (Either.Right config) | None -> Some (Either.Left t) end with _ -> None (* ******************************************** ipcalc ******************************************** *) let ipcalc ((i1,i2,i3,i4) as ip) cidr = let (n1,n2,n3,n4) as netmask = netmask_of_cidr cidr in let (a1,a2,a3,a4) as network = (i1 land n1, i2 land n2, i3 land n3, i4 land n4) in (* network address *) let (d1,d2,d3,d4) = (255 lxor n1, 255 lxor n2, 255 lxor n3, 255 lxor n4) in (* capacity delta *) let (b1,b2,b3,b4) as broadcast = (a1+d1, a2+d2, a3+d3, a4+d4) in let hostmin = (a1,a2,a3,a4+1) in let hostmax = (b1,b2,b3,b4-1) in let hostmin = max (min hostmin hostmax) network and hostmax = min (max hostmin hostmax) broadcast in let contains x = (x >= hostmin && x <= hostmax) in let hosts = match cidr with | 32 -> 1 | 31 -> 2 | _ -> (int_of_float (2. ** (float_of_int (32-cidr)))) - 2 in let s = to_string in let s_ip = lazy (s ip) in let s_cidr = lazy (string_of_int cidr) in let s_config = lazy (string_of_config (ip,cidr)) in let s_netmask = lazy (s netmask) in let s_network = lazy (s network) in let s_hostmin = lazy (s hostmin) in let s_hostmax = lazy (s hostmax) in let s_broadcast = lazy (s broadcast) in object method ip = ip method cidr = cidr method config = (ip,cidr) method netmask = netmask method network = network method broadcast = broadcast method hostmin = hostmin method hostmax = hostmax method hosts = hosts method contains = contains method contains_socket (t, _port) = contains t method print = Printf.kfprintf flush stdout "Address: %s Netmask: %s = %d => Network: %s/%d HostMin: %s HostMax: %s Broadcast: %s Hosts: %d " (Lazy.force s_ip) (Lazy.force s_netmask) cidr (Lazy.force s_network) cidr (Lazy.force s_hostmin) (Lazy.force s_hostmax) (Lazy.force s_broadcast) hosts method to_string = object method ip = (Lazy.force s_ip) method cidr = (Lazy.force s_cidr) method config = (Lazy.force s_config) method netmask = (Lazy.force s_netmask) method network = (Lazy.force s_network) method broadcast = (Lazy.force s_broadcast) method hostmax = (Lazy.force s_hostmax) method hostmin = (Lazy.force s_hostmin) end end ;; (** Similar tools working on strings and producing strings. *) module String = struct let is_valid_ipv4 x = try let _ = of_string x in true with _ -> false let is_valid_netmask x = try let _ = netmask_of_string x in true with _ -> false let is_valid_config x = try let _ = config_of_string x in true with _ -> false let ipcalc ~config:config = match Option.apply_or_catch config_of_string config with | None -> invalid_arg ("Ipv4.String.ipcalc: ill-formed address/cidr: "^config) | Some (t, cidr) -> begin let x = ipcalc t cidr in object method ip = x#to_string#ip method cidr = string_of_int (x#cidr) method netmask = x#to_string#netmask method network = x#to_string#network method broadcast = x#to_string#broadcast method hostmax = x#to_string#hostmax method hostmin = x#to_string#hostmin method contains ~ip = x#contains (of_string ip) method contains_socket ~socket = x#contains_socket (socket_of_string socket) method print = x#print end (* object *) end end ocamlbricks-0.90+bzr456.orig/STRUCTURES/multimap.mli0000644000175000017500000000623613175721005021010 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for (and instances of) the standard module [Map]. *) (* TODO: add wrappers for the functions introduced in OCaml 3.12: *) module type S = sig type key type elt type elt_set type t val empty : t val is_empty : t -> bool val add : key -> elt -> t -> t val find : key -> t -> elt_set val find_list : ?sort:unit -> key -> t -> elt list val remove_key : key -> t -> t val remove : key -> elt -> t -> t val mem_key : key -> t -> bool val mem : key -> elt -> t -> bool val iter_key : (key -> elt_set -> unit) -> t -> unit val iter : (key -> elt -> unit) -> t -> unit val fold_key : (key -> elt_set -> 'b -> 'b) -> t -> 'b -> 'b val fold : (key -> elt -> 'b -> 'b) -> t -> 'b -> 'b val compare : t -> t -> int val equal : t -> t -> bool (* Extra functions: *) val filter_key : (key -> elt_set -> bool) -> t -> t val filter : (key -> elt -> bool) -> t -> t val of_list : ?acc:t -> (key * elt) list -> t val to_list : ?acc:(key * elt) list -> ?sort:unit -> t -> (key * elt) list val domain : ?sort:unit -> t -> key list val codomain : ?sorted_by_key:unit -> t -> elt list val restrict : t -> key list -> t val diff : t -> t -> t val inter : t -> t -> t val union : t -> t -> t end module Make : functor (Ord_key : Map.OrderedType) -> functor (Ord_elt : Map.OrderedType) -> S with type key = Ord_key.t and type elt = Ord_elt.t and type elt_set = SetExtra.Make(Ord_elt).t IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Examples : sig (* I'm forced to export the module Ord_elt to express the type String2int.elt_set (by the expression SetExtra.Make(Ord_elt).t) *) module Ord_elt : Map.OrderedType with type t = int module String2int : S with type key = string and type elt = int and type elt_set = SetExtra.Make(Ord_elt).t val t : String2int.t val t' : String2int.t val diff : String2int.t val inter : String2int.t val union : String2int.t val list_of_t : (string * int) list val list_of_t' : (string * int) list val list_of_diff : (string * int) list val list_of_inter : (string * int) list val list_of_union : (string * int) list end ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/bit.mli0000644000175000017500000000222513175721005017730 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Some utilities about bits. Notice that these functions are not implemented aiming to the best efficiency. They are thinked for small problems related to mask of bits (unix permissions, IP,...). *) val bits_as_booleans_of_int : ?length:int -> int -> bool list val int_of_bits_as_booleans : bool list -> int val bits_as_integers_of_int : ?length:int -> int -> int list val int_of_bits_as_integers : int list -> int ocamlbricks-0.90+bzr456.orig/STRUCTURES/network.mli0000644000175000017500000003377113175721005020655 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2011, 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** High-level interface for client-server programming. *) exception Accepting of exn exception Connecting of exn exception Receiving of exn exception Sending of exn exception Closing of exn exception Binding of exn val string_of_sockaddr : Unix.sockaddr -> string val socketfile_of_sockaddr : Unix.sockaddr -> string val inet_addr_and_port_of_sockaddr : Unix.sockaddr -> Unix.inet_addr * int val domain_of_inet_addr : Unix.inet_addr -> Unix.socket_domain (** Example: {[# Network.socketname_in_a_fresh_made_directory "ctrl" ;; : string = "/tmp/.toplevel-2dd2c2-sockets/ctrl" # Sys.file_exists "/tmp/.toplevel-2dd2c2-sockets/ctrl" ;; : bool = false # Sys.file_exists "/tmp/.toplevel-2dd2c2-sockets" ;; : bool = true # exit 0 ;; $ test -e /tmp/.toplevel-2dd2c2-sockets || echo "Directory automatically removed" Directory automatically removed ]} *) val socketname_in_a_fresh_made_directory : ?temp_dir:string -> ?prefix:string -> ?suffix:string -> ?perm:int-> string -> string val fresh_socketname : ?temp_dir:string -> ?prefix:string -> ?suffix:string -> unit -> string class stream_channel : ?max_input_size:int -> Unix.file_descr -> object method send : string -> unit method receive : ?at_least:int -> unit -> string method peek : ?at_least:int -> unit -> string option method input_char : unit -> char method input_line : unit -> string method input_byte : unit -> int method input_binary_int : unit -> int method input_value : unit -> 'a method output_char : char -> unit method output_line : string -> unit method output_byte : int -> unit method output_binary_int : int -> unit method output_value : 'b -> unit method shutdown : ?receive:unit -> ?send:unit -> unit -> unit method sockaddr0 : Unix.sockaddr method sockaddr1 : Unix.sockaddr method get_recv_wait_at_least : int method get_send_wait_at_least : int method set_recv_wait_at_least : int -> unit method set_send_wait_at_least : int -> unit method get_recv_buffer_size : int method get_send_buffer_size : int method set_recv_buffer_size : int -> unit method set_send_buffer_size : int -> unit method get_close_linger : int option method set_close_linger : int option -> unit end val line_oriented_channel_of_stream_channel : stream_channel -> < receive : unit -> string; send : string -> unit; peek : unit -> string option; > class seqpacket_channel : ?max_input_size:int -> Unix.file_descr -> object method send : string -> unit method receive : unit -> string method peek : unit -> string option method shutdown : ?receive:unit -> ?send:unit -> unit -> unit method sockaddr0 : Unix.sockaddr method sockaddr1 : Unix.sockaddr method get_recv_buffer_size : int method get_send_buffer_size : int method set_recv_buffer_size : int -> unit method set_send_buffer_size : int -> unit method get_close_linger : int option method set_close_linger : int option -> unit end class dgram_channel : ?max_input_size:int -> fd0:Unix.file_descr -> sockaddr1:Unix.sockaddr -> unit -> object method send : string -> unit method receive : unit -> string method peek : unit -> string option method shutdown : ?receive:unit -> ?send:unit -> unit -> unit method sockaddr0 : Unix.sockaddr method sockaddr1 : Unix.sockaddr method chmod_sockaddr0 : int -> unit method get_recv_buffer_size : int method get_send_buffer_size : int method set_recv_buffer_size : int -> unit method set_send_buffer_size : int -> unit method get_close_linger : int option method set_close_linger : int option -> unit end val dgram_input_socketfile_of : ?dgram_output_socketfile:string -> stream_socketfile:string -> unit -> Unix.file_descr * Unix.sockaddr * string val dgram_input_port_of : ?dgram_output_port:int -> my_stream_inet_addr:Unix.inet_addr -> unit -> Unix.file_descr * Unix.sockaddr * int type 'a stream_protocol = stream_channel -> 'a type 'a seqpacket_protocol = seqpacket_channel -> 'a type 'a dgram_protocol = (stream_channel -> dgram_channel) * (dgram_channel -> 'a) (** The behaviour of the thread tutoring a created process may be provided specifying what there is to do before and what to do after waiting the termination of the process. *) type tutoring_thread_behaviour = ThreadExtra.Easy_API.options (** {2 Seqpacket Unix Domain } *) val seqpacket_unix_server : ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?socketfile:string -> protocol:(seqpacket_channel -> unit) -> unit -> Thread.t * string val seqpacket_unix_client : ?max_input_size:int -> socketfile:string -> protocol:(seqpacket_channel -> 'a) -> unit -> (exn,'a) Either.t (** {2 Stream Unix Domain } *) val stream_unix_server : ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?socketfile:string -> protocol:(stream_channel -> unit) -> unit -> Thread.t * string val stream_unix_client : ?max_input_size:int -> socketfile:string -> protocol:(stream_channel -> 'a) -> unit -> (exn,'a) Either.t (** {2 Stream Internet Domain } *) val stream_inet4_server : ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?ipv4:string -> ?port:int -> protocol:(stream_channel -> unit) -> unit -> Thread.t * string * int val stream_inet6_server : ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range6:string -> ?ipv6:string -> ?port:int -> protocol:(stream_channel -> unit) -> unit -> Thread.t * string * int val stream_inet_server : ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?range6:string -> ?ipv4:string -> ?ipv6:string -> ?port:int -> protocol:(stream_channel -> unit) -> unit -> (Thread.t * string * int) * (Thread.t * string * int) val stream_inet_client : ?max_input_size:int -> ipv4_or_v6:string -> port:int -> protocol:(stream_channel -> 'a) -> unit -> (exn,'a) Either.t (* datagram - unix *) val dgram_unix_server : ?max_pending_requests:int -> ?stream_max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?socketfile:string -> bootstrap:(stream_channel -> dgram_channel) -> protocol:(dgram_channel -> unit) -> unit -> Thread.t * string val dgram_unix_client : ?stream_max_input_size:int -> socketfile:string -> bootstrap:(stream_channel -> dgram_channel) -> protocol:(dgram_channel -> 'a) -> unit -> (exn,'a) Either.t (* datagram - inet & inet6 *) val dgram_inet4_server : ?max_pending_requests:int -> ?stream_max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?ipv4:string -> ?port:int -> bootstrap:(stream_channel -> dgram_channel) -> protocol:(dgram_channel -> unit) -> unit -> Thread.t * string * int val dgram_inet6_server : ?max_pending_requests:int -> ?stream_max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range6:string -> ?ipv6:string -> ?port:int -> bootstrap:(stream_channel -> dgram_channel) -> protocol:(dgram_channel -> unit) -> unit -> Thread.t * string * int val dgram_inet_server : ?max_pending_requests:int -> ?stream_max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?range6:string -> ?ipv4:string -> ?ipv6:string -> ?port:int -> bootstrap:(stream_channel -> dgram_channel) -> protocol:(dgram_channel -> unit) -> unit -> (Thread.t * string * int) * (Thread.t * string * int) val dgram_inet_client : ?stream_max_input_size:int -> ipv4_or_v6:string -> port:int -> bootstrap:(stream_channel -> dgram_channel) -> protocol:(dgram_channel -> 'a) -> unit -> (exn,'a) Either.t module Socat : sig (* -------------------------------- * of_unix_stream_server * -------------------------------- *) val inet4_of_unix_stream_server : (* inet4 server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?ipv4:string -> ?port:int -> (* unix client parameters: *) socketfile:string -> unit -> (* inet4 server result: *) Thread.t * string * int val inet6_of_unix_stream_server : (* inet6 server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range6:string -> ?ipv6:string -> ?port:int -> (* unix client parameters: *) socketfile:string -> unit -> (* inet6 server result: *) Thread.t * string * int val inet_of_unix_stream_server : (* inet4 and inet6 server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?range6:string -> ?ipv4:string -> ?ipv6:string -> ?port:int -> (* unix client parameters: *) socketfile:string -> unit -> (* inet4 and inet6 dual server result: *) (Thread.t * string * int) * (Thread.t * string * int) val unix_of_unix_stream_server : (* unix server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?socketfile:string -> (* unix client parameters: *) dsocketfile:string -> unit -> (* unix server result: *) Thread.t * string (* -------------------------------- * of_inet_stream_server * -------------------------------- *) val unix_of_inet_stream_server : (* unix server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?socketfile:string -> (* inet client parameters: *) ipv4_or_v6:string -> port:int -> unit -> (* unix server result: *) Thread.t * string val inet4_of_inet_stream_server : (* inet4 server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?ipv4:string -> ?port:int -> (* inet client parameters: *) ipv4_or_v6:string -> dport:int -> unit -> (* inet4 server result: *) Thread.t * string * int val inet6_of_inet_stream_server : (* inet4 server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range6:string -> ?ipv6:string -> ?port:int -> (* inet client parameters: *) ipv4_or_v6:string -> dport:int -> unit -> (* inet4 server result: *) Thread.t * string * int val inet_of_inet_stream_server : (* inet4 server parameters: *) ?max_pending_requests:int -> ?max_input_size:int -> ?tutor_behaviour:tutoring_thread_behaviour -> ?no_fork:unit -> ?range4:string -> ?range6:string -> ?ipv4:string -> ?ipv6:string -> ?port:int -> (* inet client parameters: *) ipv4_or_v6:string -> dport:int -> unit -> (* inet4 and inet6 dual server result: *) (Thread.t * string * int) * (Thread.t * string * int) end IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Examples : sig (* Set to 10 (chars). This setting is useful to observe the distinct semantics of the server receive function according to the kind of socket (stream, dgram, seqpacket). *) val server_max_input_size : int val simple_echo_server_protocol : < receive : unit -> string; send : string -> unit; .. > -> unit val simple_echo_client_protocol : < receive : unit -> string; send : string -> unit; .. > -> unit (* Here the method #receive is redefined as #input_line, thus the parameter `max_input_size' is meaningless in this case and the whole line is received by the server: *) val stream_unix_echo_server : ?no_fork:unit -> ?socketfile:string -> unit -> Thread.t * string val stream_unix_echo_client : socketfile:string -> unit -> (exn, unit) Either.t (* Sending a message bigger than 10 characters, we receive a bad (trunked) echo: *) val seqpacket_unix_echo_server : ?no_fork:unit -> ?socketfile:string -> unit -> Thread.t * string val seqpacket_unix_echo_client : socketfile:string -> unit -> (exn, unit) Either.t val dgram_unix_echo_server : ?no_fork:unit -> ?stream_socketfile:string -> unit -> Thread.t * string val dgram_unix_echo_client : stream_socketfile:string -> unit -> (exn, unit) Either.t val stream_inet_echo_server : ?no_fork:unit -> ?inet6:unit -> ?port:int -> unit -> Thread.t * string * int val stream_inet_echo_client : ipv4_or_v6:string -> port:int -> unit -> (exn, unit) Either.t val dgram_inet_echo_server : ?no_fork:unit -> ?inet6:unit -> ?port:int -> unit -> Thread.t * string * int val dgram_inet_echo_client : ipv4_or_v6:string -> port:int -> unit -> (exn, unit) Either.t end ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/default.mli0000644000175000017500000000243713175721005020603 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Manage global defaults for your optional parameters. If the field mutex is [true] the access is synchronized by a mutex (thread safe). {b Example}: {[ module Default_foo = Default.Make(struct type t = foo_type let create () = .. let mutex = false end) let my_function ?foo .. = let foo = Default_foo.extract_or_get_default foo in ... ]} *) module Make : functor (Value : sig type t val create : unit -> t val mutex : bool end) -> sig type t = Value.t val get : unit -> t val set : t -> unit val extract_or_get_default : t option -> t end ocamlbricks-0.90+bzr456.orig/STRUCTURES/rev.ml0000644000175000017500000000643013175721005017577 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* For efficiency I rewrite a little stack library. *) type 'a stack = { mutable l : 'a list } let stack_create () = { l = [] } let stack_clear s = s.l <- [] let stack_push x s = s.l <- x :: s.l let stack_pop s = match s.l with x::xs -> s.l <- xs; x | [] -> assert false let stack_top s = match s.l with x::_ -> x | [] -> assert false let stack_is_singleton s = (match s.l with [x] -> true | _ -> false) let stack_iter f s = List.iter f s.l (** The abstract type of reversible references. *) type 'a t = { mutable previous : 'a list; mutable current : 'a } (** Create a reversible reference. *) let create (v:'a) : 'a t = { previous = []; current = v } type 'a register = ('a stack) stack (* A first parenthesis is implicitely opened. I use Obj.magic for efficiency reasons (thunks need to be applied). *) let the_register = let r = stack_create () in let s = stack_create () in let () = stack_push s r in (Obj.magic r) let register_change (t:'a t) = let s = stack_top the_register in stack_push t s (** Extract the value of the reference. *) let get t = t.current (** Set the value of the reference. *) let set t v = begin t.previous <- t.current :: t.previous ; t.current <- v; register_change t; end (* Called by the register. *) let unset t : unit = match t.previous with | v::l -> t.previous <- l; t.current <- v; | [] -> assert false (** Define a backtracking point. *) let open_parenthesis () = let s = stack_create () in stack_push s the_register (** Return to the backtracking point defined by the last opened parenthesis. May raise a failure in case of unbalanced parenthesis. *) let close_parenthesis () = if stack_is_singleton the_register then failwith "Rev.close_parenthesis: unbalanced usage of parenthesis." else let s = stack_pop the_register in stack_iter unset s (** Return to the backtracking point of the last opened parenthesis but the parenthesis is not closed: any future operation will concern this parenthesis (this stack) and not its parent. *) let back_parenthesis () = let s = stack_top the_register in (stack_iter unset s); (stack_clear s) (** Opening this module you redefine the standard [ref], [!] and [:=] in order to operate on this kind of structure instead of standard references. *) module Toolkit = struct let ref v = { previous = []; current = v } let (!) t = t.current let (:=) t v = begin t.previous <- t.current :: t.previous ; t.current <- v; register_change t; end end ocamlbricks-0.90+bzr456.orig/STRUCTURES/functor.ml0000644000175000017500000000567113175721005020471 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Reference-based folders built from the functor (map). *) let fold_of_functor : map:(('x -> 'y) -> 'x_t -> 'y_t) -> ('a -> 'x -> 'a) -> 'a -> 'x_t -> 'a = fun ~map f s0 xs -> let state = ref s0 in let _ = map (fun x -> (state := f !state x)) xs in !state ;; let map_and_fold_of_functor : map:(('x -> 'y) -> 'x_t -> 'y_t) -> ('a -> 'x -> 'y * 'a) -> 'a -> 'x_t -> 'y_t * 'a = fun ~map f s0 xs -> let state = ref s0 in let ys = map (fun x -> let (c,a) = f !state x in state := a; c) xs in (ys, !state) ;; let map_and_fold_of_bifunctor : map:(('x1 -> 'y1) -> ('x2 -> 'y2) -> 'x1x2_t -> 'y1y2_t) -> ('a -> 'x1 -> 'y1 * 'a) -> ('a -> 'x2 -> 'y2 * 'a) -> 'a -> 'x1x2_t -> 'y1y2_t * 'a = fun ~map f1 f2 s0 xs -> let state = ref s0 in let ys = map (fun x1 -> let (y1,a) = f1 !state x1 in state := a; y1) (fun x2 -> let (y2,a) = f2 !state x2 in state := a; y2) xs in (ys, !state) let fold_of_bifunctor : map:(('x1 -> 'y1) -> ('x2 -> 'y2) -> 'x1x2_t -> 'y1y2_t) -> ('a -> 'x1 -> 'a) -> ('a -> 'x2 -> 'a) -> 'a -> 'x1x2_t -> 'a = fun ~map f1 f2 s0 xs -> let state = ref s0 in let _ = map (fun x1 -> state := f1 !state x1) (fun x2 -> state := f2 !state x2) xs in !state let map_and_fold_of_trifunctor : map:(('x1 -> 'y1) -> ('x2 -> 'y2) -> ('x3 -> 'y3) -> 'x1x2x3_t -> 'y1y2y3_t) -> ('a -> 'x1 -> 'y1 * 'a) -> ('a -> 'x2 -> 'y2 * 'a) -> ('a -> 'x3 -> 'y3 * 'a) -> 'a -> 'x1x2x3_t -> 'y1y2y3_t * 'a = fun ~map f1 f2 f3 s0 xs -> let state = ref s0 in let ys = map (fun x1 -> let (y1,a) = f1 !state x1 in state := a; y1) (fun x2 -> let (y2,a) = f2 !state x2 in state := a; y2) (fun x3 -> let (y3,a) = f3 !state x3 in state := a; y3) xs in (ys, !state) let fold_of_trifunctor : map:(('x1 -> 'y1) -> ('x2 -> 'y2) -> ('x3 -> 'y3) -> 'x1x2x3_t -> 'y1y2y3_t) -> ('a -> 'x1 -> 'a) -> ('a -> 'x2 -> 'a) -> ('a -> 'x3 -> 'a) -> 'a -> 'x1x2x3_t -> 'a = fun ~map f1 f2 f3 s0 xs -> let state = ref s0 in let _ = map (fun x1 -> state := f1 !state x1) (fun x2 -> state := f2 !state x2) (fun x3 -> state := f3 !state x3) xs in !state ocamlbricks-0.90+bzr456.orig/STRUCTURES/semaphore.mli0000644000175000017500000000354013175721005021136 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) type t val create : ?mutex:Mutex.t -> ?condition:Condition.t -> ?init:int -> unit -> t val p : ?n:int -> t -> unit val v : ?n:int -> t -> unit val p_nowait : ?n:int -> t -> bool val with_semaphore : ?n:int -> t -> (unit -> 'a) -> 'a module Array_and : functor (M : sig val dim : int end) -> sig val dim : int val create : ?mutex:Mutex.t -> ?condition:Condition.t -> ?init:int array -> unit -> t array val p : ?n:int array -> t array -> unit val v : ?n:int array -> t array -> unit val p_nowait : ?n:int array -> t array -> bool val with_semaphore : ?n:int array -> t array -> (unit -> 'a) -> 'a end module Array_or : functor (M : sig val dim : int end) -> sig val dim : int val create : ?mutex:Mutex.t -> ?condition:Condition.t -> ?init:int array -> unit -> t array val p : ?n:int array -> t array -> int * int val p_nowait : ?n:int array -> t array -> (int * int) option val v : i:int -> n:int -> t array -> unit val with_semaphore : ?n:int array -> t array -> (i:int -> n:int -> 'a) -> 'a end ocamlbricks-0.90+bzr456.orig/STRUCTURES/memo.mli0000644000175000017500000000224613175721005020112 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2011 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Simple function memoization.*) val default_size : int (** Transform a function into its memoized version. *) val memoize : ?trace_faults:unit -> ?trace_success:unit -> ?size:int -> ('a -> 'b) -> 'a -> 'b (** In order to manually manage the memory allocation it may be useful to get also the hash table: *) val memoize_and_get_table : ?trace_faults:unit -> ?trace_success:unit -> ?size:int -> ('a -> 'b) -> ('a -> 'b) * ('a,'b) Hashtbl.t ocamlbricks-0.90+bzr456.orig/STRUCTURES/egg.mli0000644000175000017500000000427313175721005017721 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Single-writer/multi-readers {e egg} synchronization structure. Eggs are very close to {b futures}: someone in the system (the {e writer}) has to perform a job for itself and/or for others (the {e readers}). In this sense, readers wait until the writer "make the egg". The egg is ready when it is released by the writer. When this happen, the writer broadcast all pending readers. Future readers will get the egg immediately without waiting. There's just a little {b difference between eggs and futures}: the role writer/reader of an agent is not known a priori, but could be defined dynamically. More specifically, the boolean and {b non-blocking} function [acquire_release_power] allows a potential writer to acquire the power to perform the job. If it succeed the agent become a writer, otherwise it should become a reader waiting for the egg produced by someone else. The typical scheme (where t is an egg) is: {[let result = if Egg.acquire_release_power t then (* I'm the writer *) let result = (* perform the job *) in (Egg.release t); result else (* I'm a reader *) Egg.wait t ]} If you know a priori the writer, you dont need to call the function [acquire_release_power]. In other terms, you are using eggs as futures. *) type 'a t val create : unit -> 'a t val acquire_release_power : 'a t -> bool val wait : 'a t -> 'a val taste : 'a t -> 'a option val release : 'a t -> 'a -> unit ocamlbricks-0.90+bzr456.orig/STRUCTURES/endpoint.mli0000644000175000017500000001352313175721005020775 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) module Source : sig type t = | Unix_descr of Unix.file_descr | In_channel of in_channel | Filename of string | String of string | Empty val to_file_descr : t -> Unix.file_descr * bool val to_in_channel : t -> in_channel * bool val to_string : t -> string val with_file_descr : t -> (Unix.file_descr -> 'a) -> 'a val with_in_channel : t -> (in_channel -> 'a) -> 'a (** {2 Source iterators (map, iter, fold) } *) type line = string type word = string type delimiter = char type recno = int (* The total number of input records seen so far, starting from 1 *) type fieldno = int (* The total number of fields seen so far, starting from 1 *) (** {b Iterators on lines } *) val fold_lines : ('a -> recno -> line -> 'a) -> 'a -> t -> 'a val map_lines : (recno -> line -> 'a) -> t -> 'a array val iter_lines : (recno -> line -> unit) -> t -> unit (** {b Iterators on lines considered as word lists } *) val map_word_lists : ?d:delimiter -> (recno -> word list -> 'a) -> t -> 'a array val iter_word_lists : ?d:delimiter -> (recno -> word list -> unit) -> t -> unit val fold_word_lists : ?d:delimiter -> ('a -> recno -> word list -> 'a) -> 'a -> t -> 'a (** {b Iterators on lines considered as word arrays } *) val map_word_arrays : ?d:delimiter -> (recno -> word array -> 'a) -> t -> 'a array val iter_word_arrays : ?d:delimiter -> (recno -> word array -> unit) -> t -> unit val fold_word_arrays : ?d:delimiter -> ('a -> recno -> word array -> 'a) -> 'a -> t -> 'a (** {b Iterators on words } *) val fold_words : ?d:delimiter -> ('a -> recno -> fieldno -> word -> 'a) -> 'a -> t -> 'a val iter_words : ?d:delimiter -> (recno -> fieldno -> word -> unit) -> t -> unit val map_words : ?d:delimiter -> (recno -> fieldno -> word -> 'a) -> t -> 'a array array end module Sink : sig type t = | Unix_descr of Unix.file_descr | Out_channel of out_channel | Filename of string | Filename_append of string | Filename_overtype of string | Fun_thread of (Unix.file_descr -> unit) | String_queue of String_queue.t | Trash val to_file_descr : t -> Unix.file_descr * bool val to_out_channel : t -> out_channel * bool val to_string : t -> string val with_out_channel : t -> (out_channel -> 'a) -> 'a val with_file_descr : t -> (Unix.file_descr -> 'a) -> 'a (** {2 Print arrays of strings} Note that the names of the optional parameters [?rs] (line/record separator) and [?fs] (word/field separator) have been choosen to resemble to the corrispondent variables in [awk]. *) type line = string type word = string type linesep = string type wordsep = string val print_string : t -> string -> unit val print_lines : ?rs:linesep -> t -> line array -> unit val print_word_lists : ?rs:linesep -> ?fs:wordsep -> t -> word list array -> unit val print_word_arrays : ?rs:linesep -> ?fs:wordsep -> t -> word array array -> unit (** {2 Print arrays of tuples} {b Example}: {[ Sink.printf2 (Sink.Filename "/tmp/foo") "%s ==> %F\n" [| ("AAA", 3.14); ("BBB", 6.28); |] ;; : unit = () UnixExtra.cat "/tmp/foo" ;; : string = "AAA ==> 3.14\nBBB ==> 6.28\n" ]} *) val printf1 : t -> ('x1 -> unit, out_channel, unit) format -> 'x1 array -> unit val printf2 : t -> ('x1 -> 'x2 -> unit, out_channel, unit) format -> ('x1 * 'x2) array -> unit val printf3 : t -> ('x1 -> 'x2 -> 'x3 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3) array -> unit val printf4 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4) array -> unit val printf5 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5) array -> unit val printf6 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6) array -> unit val printf7 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> 'x7 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6 * 'x7) array -> unit val printf8 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> 'x7 -> 'x8 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6 * 'x7 * 'x8) array -> unit val printf9 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> 'x7 -> 'x8 -> 'x9 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6 * 'x7 * 'x8 * 'x9) array -> unit val printf10 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> 'x7 -> 'x8 -> 'x9 -> 'x10 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6 * 'x7 * 'x8 * 'x9 * 'x10) array -> unit val printf11 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> 'x7 -> 'x8 -> 'x9 -> 'x10 -> 'x11 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6 * 'x7 * 'x8 * 'x9 * 'x10 * 'x11) array -> unit val printf12 : t -> ('x1 -> 'x2 -> 'x3 -> 'x4 -> 'x5 -> 'x6 -> 'x7 -> 'x8 -> 'x9 -> 'x10 -> 'x11 -> 'x12 -> unit, out_channel, unit) format -> ('x1 * 'x2 * 'x3 * 'x4 * 'x5 * 'x6 * 'x7 * 'x8 * 'x9 * 'x10 * 'x11 * 'x12) array -> unit end ocamlbricks-0.90+bzr456.orig/STRUCTURES/cloakroom.ml0000644000175000017500000001001313175721005020761 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) module Id_map = MapExtra.Int_map type id = int type revision = int type 'a t = ('a,id) Hashtbl.t * ('a Id_map.t ref) * (unit->id) * (revision ref) let create ?(size=251) () : 'a t = let revision = ref 0 in let id_counter = ref 0 in let fresh = fun () -> (incr id_counter); !id_counter in (Hashtbl.create size, ref Id_map.empty, fresh, revision) let add (ta,ti,fresh,revision) a = try Hashtbl.find ta a with Not_found | Invalid_argument _ (*"equal: functional value"*) -> let id = fresh () in (ti := Id_map.add id a !ti); (Hashtbl.add ta a id); (incr revision); id let remove (ta,ti,fresh,revision) id = try let a = Id_map.find id !ti in (Hashtbl.remove ta a); (ti := Id_map.remove id !ti); (incr revision); true with Not_found -> false let mem (ta,ti,fresh,revision) id = Id_map.mem id !ti let length (ta,ti,fresh,revision) = Hashtbl.length ta let revision (ta,ti,fresh,revision) = !revision let iter f (ta,ti,fresh,revision) = Id_map.iter f !ti let fold f (ta,ti,fresh,revision) = Id_map.fold f !ti let to_list (ta,ti,fresh,revision) = Id_map.codomain !ti let to_assoc_list (ta,ti,fresh,revision) = Id_map.to_list !ti let of_list xs = let t = create () in let ys = List.map (add t) xs in (t,ys) module Cached = struct let to_list t = Cache.optimize ~revision:revision to_list t let to_assoc_list t = Cache.optimize ~revision:revision to_assoc_list t end (** Heterogenous cloakroom. add is O(n), remove is O(1), find is O(1). Obj.magic is needed here, of course. Use [find] with caution. {b Example}: {[# let t = M.create () ;; val t : M.t = # M.add t 42 ;; : M.id = 1 # M.add t 3.14 ;; : M.id = 2 # M.add t [true;false;false] ;; : M.id = 3 # M.add t (fun x -> x+1) ;; : M.id = 4 # List.hd (M.find t 3) ;; : 'a = # List.hd ((M.find t 3):bool list) ;; : bool = true # List.tl ((M.find t 3):bool list) ;; : bool list = [false; false] ]} *) module Hetero = struct type id = int type revision = int (* Note that here an hash table for (id,'a) associations is preferable (instead of an heap) because we don't worry about folding/itering complexity. For the same reason, the field revision is not very interesting. The field length is now not necessary because Hashtbl.length is efficient. *) type 'a the_type_if_it_was_homogeneous = (('a * id) list ref) * (id,'a) Hashtbl.t * (unit->id) type invention = int option type t = invention the_type_if_it_was_homogeneous let create ?(size=251) () = let id_counter = ref 0 in let fresh = fun () -> (incr id_counter); !id_counter in (ref [], Hashtbl.create size, fresh) let add (ta,ti,fresh) a = try List.assq a !ta with Not_found -> let id = fresh () in let () = ((ta := (a,id)::(!ta)); (Hashtbl.add ti id a)) in id let remove (ta,ti,fresh) id = try let a = Hashtbl.find ti id in (ta := List.remove_assq a !ta); (Hashtbl.remove ti id); true with Not_found -> false let find (ta,ti,fresh) id = Hashtbl.find ti id (* add is redefined with magic: *) let add t a = add (Obj.magic t) (Obj.magic a) let find t id = find (Obj.magic t) id let mem (ta,ti,fresh) id = Hashtbl.mem ti id let length (ta,ti,fresh) = Hashtbl.length ti end ocamlbricks-0.90+bzr456.orig/STRUCTURES/endpoint.ml0000644000175000017500000003133513175721005020625 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Abstract channel endpoints (sources and sinks). *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF (** Abstract source (or negative) channel endpoints. *) module Source = struct (** The abstract type of a source endpoint *) type t = | Unix_descr of Unix.file_descr (** An already opened unix descriptor. *) | In_channel of in_channel (** An already opened pervasives input channel. *) | Filename of string (** A file name. *) | String of string (** A string content. *) | Empty (** A shorthand for [String ""] *) (** A string description of the source, for building messages. *) let to_string = function | Unix_descr c when c=Unix.stdin -> "stdin" | Unix_descr _ -> "Unix descriptor" | In_channel c when c=stdin -> "stdin" | In_channel c -> "in_channel" | Filename f -> f | String s -> "String \""^s^"\"" | Empty -> "Empty" (** Create a unix file descriptor from a source if necessary. The function returns also a flag indicating if the descriptor must be closed. If the user has given directly a descriptor (unix or standard), the descriptor do not must be closed. If the user has given a filename, the on-the-fly created descriptor must be closed. *) let to_file_descr = let in_descr_of_string s = let len = (String.length s) in let (pread,pwrite) = Unix.pipe () in let count = (Unix.write pwrite s 0 len) in (assert (count = len)); (Unix.close pwrite); pread in function | Unix_descr d -> (d, false) | In_channel c -> ((Unix.descr_of_in_channel c), false) | Filename s -> ((Unix.openfile s [Unix.O_RDONLY] 0o640), true) | String s -> ((in_descr_of_string s),true) | Empty -> ((in_descr_of_string ""),true) (** Same as [to_file_descr] but to create pervasives input channels. *) let to_in_channel = function | Unix_descr d -> ((Unix.in_channel_of_descr d), false) | In_channel c -> (c, false) | other_case -> let d, flag = to_file_descr (other_case) in (Unix.in_channel_of_descr d), flag type line = string (** Lines are strings separated by ['\n'] in the source *) type word = string (** Words are substrings of a line *) type delimiter = char (** Word delimiter, the Blank character by default *) type recno = int (** The total number of input records seen so far, starting from [1] *) type fieldno = int (** The total number of fields seen so far, starting from [1] *) (** Open and convert the source into a channel, apply the function, then close it if necessary. *) let with_in_channel t (f : in_channel -> 'a) = let (ch, flag) = to_in_channel t in let result = f ch in let () = if flag then (close_in ch) in result (** Open and convert the source into a file descriptor, apply the function, then close it if necessary. *) let with_file_descr t (f : Unix.file_descr -> 'a) = let (fd, flag) = to_file_descr t in let result = f fd in let () = if flag then (Unix.close fd) in result (* Re-implemented in imperative style in order to avoid "Stack overflow during evaluation (looping recursion?)". *) let fold_lines (f : 'a -> recno -> line -> 'a) s t : 'a = with_in_channel t begin fun ch -> let acc = ref s in let i = ref 1 in let () = try while true do let line = input_line ch in let acc' = (f !acc !i line) in incr i; acc := acc'; done with End_of_file -> () in !acc end let map_lines (f : recno -> line -> 'a) t : 'a array = let (xs, size) = fold_lines (fun (acc,_) i line -> ((f i line)::acc),i) ([],0) t in ArrayExtra.of_known_length_list ~reversing:true size xs (** {b Example}: {[ Source.iter_lines (Printf.printf "(%d) %s\n") (Source.Filename "/etc/fstab") ;; ]} *) let iter_lines (f : recno -> line -> unit) t = fold_lines (fun _ i line -> (f i line)) () t (* --- *) let fold_word_lists ?d (f : 'a -> recno -> word list -> 'a) s t : 'a = fold_lines (fun a i line -> f a i (StringExtra.split ?d line)) s t let map_word_lists ?d (f : recno -> word list -> 'a) t : 'a array = map_lines (fun i line -> f i (StringExtra.split ?d line)) t let iter_word_lists ?d (f : recno -> word list -> unit) t = iter_lines (fun i line -> f i (StringExtra.split ?d line)) t (* --- *) let fold_word_arrays ?d (f : 'a -> recno -> word array -> 'a) s t : 'a = fold_lines (fun a i line -> f a i (Array.of_list (StringExtra.split ?d line))) s t let map_word_arrays ?d (f : recno -> word array -> 'a) t : 'a array = map_lines (fun i line -> f i (Array.of_list (StringExtra.split ?d line))) t let iter_word_arrays ?d (f : recno -> word array -> unit) t = iter_lines (fun i line -> f i (Array.of_list (StringExtra.split ?d line))) t (* --- *) (** {b Example}: {[ Source.fold_words (fun n _ _ _ -> n+1) 0 (Source.Filename "/etc/fstab") ;; : int = 88 UnixExtra.run "wc -w /etc/fstab" ;; : string * Unix.process_status = ("88 /etc/fstab\n", Unix.WEXITED 0) ]} *) let fold_words ?d (f : 'a -> recno -> fieldno -> word -> 'a) s t : 'a = fold_word_arrays ?d (fun s i ws -> ArrayExtra.fold_lefti (fun j a w -> f a i (j+1) w) s ws) s t let iter_words ?d (f : recno -> fieldno -> word -> unit) t = iter_word_arrays ?d (fun i ws -> Array.iteri (fun j w -> f i (j+1) w) ws) t (** {b Example}: {[ Source.map_words (fun _ _ -> String.capitalize_ascii) (Source.Filename "/etc/fstab") ;; : string array array = \[|\[|"#"; "/etc/fstab:"; "Static"; "File"; "System"; "Information."|\]; ... |\] ]} *) let map_words ?d (f : recno -> fieldno -> word -> 'a) t : 'a array array = map_word_arrays ?d (fun i ws -> Array.mapi (fun j w -> f i (j+1) w) ws) t end (** Abstract sink (or positive) channel endpoints. *) module Sink = struct (** The abstract type of a sink endpoint. *) type t = | Unix_descr of Unix.file_descr (** An already opened unix descriptor. *) | Out_channel of out_channel (** An already opened pervasives output channel. *) | Filename of string (** A file name, (re)writing. *) | Filename_append of string (** A file name, appending. *) | Filename_overtype of string (** A file name, overtyping (no truncate). *) | Fun_thread of (Unix.file_descr -> unit) (** A consumer function. *) | String_queue of String_queue.t (** A string queue. *) | Trash (** A sort of /dev/null. *) (** A string description of the sink, for building messages. *) let to_string = function | Unix_descr c when c=Unix.stdout -> "stdout" | Unix_descr c when c=Unix.stderr -> "stderr" | Unix_descr _ -> "Unix descriptor" | Out_channel c when c=stdout -> "stdout" | Out_channel c when c=stderr -> "stderr" | Out_channel c -> "out_channel" | Filename f -> f | Filename_append f -> ">>"^f | Filename_overtype f -> "overtyping "^f | Fun_thread _ -> "Fun_thread" | String_queue _ -> "String_queue" | Trash -> "Trash" (** Create a unix file descriptor from a sink if necessary. The function returns also a flag indicating if the descriptor must be closed. If the user has given directly a descriptor (unix or standard), the descriptor do not must be closed. If the user has given a filename, a treatment function or a string queue, the on-the-fly created descriptor must be closed. *) let to_file_descr = let out_descr_of_fun_thread f = let (pread,pwrite) = Unix.pipe () in let try_close d = try (Unix.close d) with _ -> () in let wrap f d = (let res = try (f d) with e -> ((try_close d); raise e) in (try_close d); res) in let () = ignore (Thread.create (wrap f) pread) in pwrite in function | Unix_descr d -> (d, false) | Out_channel c -> ((Unix.descr_of_out_channel c), false) | Filename s -> ((Unix.openfile s [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC;] 0o640), true) | Filename_append s -> ((Unix.openfile s [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND;] 0o640), true) | Filename_overtype s -> ((Unix.openfile s [Unix.O_WRONLY; Unix.O_CREAT;] 0o640), true) | Fun_thread f -> ((out_descr_of_fun_thread f),true) | String_queue q -> let f = fun fd -> String_queue.append_from_descr ~release:true q fd; in ((out_descr_of_fun_thread f),true) | Trash -> let block_size = 1024 in let buff = Bytes.create block_size in let rec trash_loop fd = let n = (Unix.read fd buff 0 block_size) in if (n=0) then () else trash_loop fd in ((out_descr_of_fun_thread trash_loop),true) (** Same as [to_file_descr] but to create pervasives output channels. *) let to_out_channel = function | Unix_descr d -> ((Unix.out_channel_of_descr d), false) | Out_channel c -> (c, false) | other_case -> let d,flag = to_file_descr (other_case) in (Unix.out_channel_of_descr d), flag (** Open and convert the sink into a channel, apply the function, then close it if necessary. *) let with_out_channel t (f : out_channel -> 'a) = let (ch, flag) = to_out_channel t in let result = f ch in let () = if flag then (try close_out ch with _ -> ()) in result (** Open and convert the sink into a file descriptor, apply the function, then close it if necessary. *) let with_file_descr t (f : Unix.file_descr -> 'a) = let (fd, flag) = to_file_descr t in let result = f fd in let () = if flag then (Unix.close fd) in result type line = string (** Lines are strings separated by default by ['\n'] in the sink *) type word = string (** Words are strings separated by default by Blanks in a line *) type linesep = string (** Line (record) separator, by default ['\n'] *) type wordsep = string (** Word (field) separator, by default [' '] (Blank) *) let print_string t s = with_out_channel t (fun ch -> Printf.kfprintf flush ch "%s" s) let print_lines ?(rs="\n") t xs = with_out_channel t (fun ch -> Array.iter (fun x -> Printf.fprintf ch "%s%s" x rs) xs) let print_word_lists ?(rs="\n") ?(fs=" ") t wss = with_out_channel t (fun ch -> Array.iter (fun ws -> Printf.fprintf ch "%s%s" (String.concat fs ws) rs) wss) let print_word_arrays ?(rs="\n") ?(fs=" ") t wss = with_out_channel t (fun ch -> Array.iter (fun ws -> Printf.fprintf ch "%s%s" (String.concat fs (Array.to_list ws)) rs) wss) let printf1 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1 -> Printf.fprintf ch fmt x1) xs) let printf2 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2 -> Printf.fprintf ch fmt x1 x2) xs) let printf3 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3 -> Printf.fprintf ch fmt x1 x2 x3) xs) let printf4 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4 -> Printf.fprintf ch fmt x1 x2 x3 x4) xs) let printf5 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5) xs) let printf6 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6) xs) let printf7 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6,x7 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6 x7) xs) let printf8 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6,x7,x8 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6 x7 x8) xs) let printf9 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6,x7,x8,x9 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6 x7 x8 x9) xs) let printf10 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) xs) let printf11 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) xs) let printf12 t fmt xs = with_out_channel t (fun ch -> Array.iter (function x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12 -> Printf.fprintf ch fmt x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) xs) end ocamlbricks-0.90+bzr456.orig/STRUCTURES/functor.mli0000644000175000017500000000343213175721005020633 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) val fold_of_functor : map:(('x -> unit (*'y*)) -> 'x_t -> 'y_t) -> ('a -> 'x -> 'a) -> 'a -> 'x_t -> 'a val map_and_fold_of_functor : map:(('x -> 'y) -> 'x_t -> 'y_t) -> ('a -> 'x -> 'y * 'a) -> 'a -> 'x_t -> 'y_t * 'a (* {2 Bifunctors} *) val fold_of_bifunctor : map:(('x1 -> unit (*'y1*)) -> ('x2 -> unit (*'y2*)) -> 'x1x2_t -> 'y1y2_t) -> ('a -> 'x1 -> 'a) -> ('a -> 'x2 -> 'a) -> 'a -> 'x1x2_t -> 'a val map_and_fold_of_bifunctor : map:(('x1 -> 'y1) -> ('x2 -> 'y2) -> 'x1x2_t -> 'y1y2_t) -> ('a -> 'x1 -> 'y1 * 'a) -> ('a -> 'x2 -> 'y2 * 'a) -> 'a -> 'x1x2_t -> 'y1y2_t * 'a (* {2 Trifunctors} *) val map_and_fold_of_trifunctor : map:(('x1 -> 'y1) -> ('x2 -> 'y2) -> ('x3 -> 'y3) -> 'x1x2x3_t -> 'y1y2y3_t) -> ('a -> 'x1 -> 'y1 * 'a) -> ('a -> 'x2 -> 'y2 * 'a) -> ('a -> 'x3 -> 'y3 * 'a) -> 'a -> 'x1x2x3_t -> 'y1y2y3_t * 'a val fold_of_trifunctor : map:(('x1 -> unit (*'y1*)) -> ('x2 -> unit (*'y2*)) -> ('x3 -> unit (*'y3*)) -> 'x1x2x3_t -> 'y1y2y3_t) -> ('a -> 'x1 -> 'a) -> ('a -> 'x2 -> 'a) -> ('a -> 'x3 -> 'a) -> 'a -> 'x1x2x3_t -> 'a ocamlbricks-0.90+bzr456.orig/STRUCTURES/hashmap.ml0000644000175000017500000001003713175721005020422 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** The default size of the hash used in the implementation *) let default_size = 251;; (** The hashmap class *) class ['a,'b] hashmap = fun ?(size=default_size) () -> object(self) (** The state of the hashmap. *) val current : ('a,'b) Hashtbl.t = (Hashtbl.create size) method get = current (** Return the object bound to the given key, or raise Not_found: *) method lookup x = (Hashtbl.find current x) (** Answer (quickly!) to the question if (x,y) is a member of the map. *) method mem x y : bool = try y = (Hashtbl.find current x) with Not_found -> false (** Answer (quickly!) to the question if (x,y) is a member of the map. *) method memq x y : bool = try y == (Hashtbl.find current x) with Not_found -> false (** Answer if x is bound in the map. *) method bound x = Hashtbl.mem current x (** Add a binding to the map *) method add x y = Hashtbl.replace current x y (** Alias for [add] *) method replace x y = Hashtbl.replace current x y (** Remove the binding for the given key. *) method remove x = Hashtbl.remove current x (** Make an alist from the map, returning the bindings as pairs in some unspecified order. *) method to_list = Hashtbl.fold (fun a b current_list -> (a, b) :: current_list) current [] (** Add all the binding from the given alist to the map. In case of multiple values for a single key it's undefined which value prevails. *) method add_list alist = ignore (List.map (fun (key, datum) -> self#add key datum) alist) end;; (* class hashmap *) (* Functional interface. *) (** The abstract type of an hashmap. *) type ('a,'b) t = ('a,'b) hashmap ;; (** The hashmap constructor. *) let make ?(size=default_size) () : ('a,'b) t = new hashmap ~size () ;; (** Return the object bound to the given key, or raise Not_found: *) let lookup (h:('a,'b) t) x = h#lookup x (** The member predicate. *) let mem (h:('a,'b) t) (x:'a) (y:'b) = h#mem x y;; (** The member predicate with the physical equality. *) let memq (h:('a,'b) t) (x:'a) (y:'b) = h#memq x y;; (** Answer if x is bound in the map. *) let bound (h:('a,'b) t) (x:'a) = h#bound x ;; (** Add a binding to the hashmap. *) let add (h:('a,'b) t) (x:'a) (y:'b) = h#add x y;; (** Add all the binding from the given alist to the map. In case of multiple values for a single key it's undefined which value prevails. *) let add_list (h:('a,'b) t) (alist:('a * 'b) list) = h#add_list alist;; (** Replace or add (when not existing) a binding to a map. *) let replace (h:('a,'b) t) (x:'a) (y:'b) = h#replace x y;; (** Remove one or all (default) bindings of the given key. *) let remove (h:('a,'b) t) (x:'a) = h#remove x;; (** [update t1 t2] updates the map [t1] adding all the bindings from [t2].*) let update (h1:('a,'b) t) (h2:('a,'b) t) : unit = Hashtbl.iter (h1#add) (h2#get) ;; (** Make an alist from an hashmap, returning the bindings as pairs in some unspecified order. *) let to_list (h:('a,'b) t) = h#to_list;; (** Make a new hashmap from an alist made of pairs. If more than one binding is specified for a single key it's undefined which value prevails. *) let of_list ?size:(size=default_size) alist = let h : ('a,'b) t = new hashmap ~size () in h#add_list alist; h;; ocamlbricks-0.90+bzr456.orig/STRUCTURES/hashmmap.mli0000644000175000017500000000435713175721005020760 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo Copyright (C) 2008 Luca Saiu (wrote the methods remove_key_value_or_fail and remove_key_value) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Polymorphic {e unbounded} {b multi} maps (environments). *) type ('a, 'b) t val make : ?size:int -> unit -> ('a, 'b) t val lookup_or_fail : ('a, 'b) t -> 'a -> 'b list val lookup : ('a, 'b) t -> 'a -> 'b list val mem : ('a, 'b) t -> 'a -> 'b -> bool val memq : ('a, 'b) t -> 'a -> 'b -> bool val bound : ('a, 'b) t -> 'a -> bool val add : ('a, 'b) t -> 'a -> 'b -> unit val add_list : ('a, 'b) t -> ('a * 'b) list -> unit val replace : ('a, 'b) t -> 'a -> 'b -> unit val remove : ('a, 'b) t -> ?all:bool -> 'a -> unit val update : ?replace:bool -> ('a, 'b) t -> ('a, 'b) t -> unit val to_list : ('a, 'b) t -> ('a * 'b) list val of_list : ?size:int -> ('a * 'b) list -> ('a, 'b) t (** {2 Object-oriented interface} *) class ['a, 'b] hashmultimap : ?size:int -> unit -> object method add : 'a -> 'b -> unit method add_list : ('a * 'b) list -> unit method bound : 'a -> bool method get : ('a, 'b) Hashtbl.t method lookup : 'a -> 'b list method lookup_or_fail : 'a -> 'b list method mem : 'a -> 'b -> bool method memq : 'a -> 'b -> bool method remove : ?all:bool -> 'a -> unit method remove_key_value : 'a -> 'b -> unit method remove_key_value_or_fail : 'a -> 'b -> unit method replace : 'a -> 'b -> unit method to_list : ('a * 'b) list end ocamlbricks-0.90+bzr456.orig/STRUCTURES/container.ml0000644000175000017500000000652613175721005020773 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../STRUCTURES/container.mli" (* Fresh is morally an optional argument of the functor: *) module Add_identifiers (Fresh : sig val fresh : (unit -> int) option end) (Container: T) : T_with_identifiers = struct type id = int type 'a t = (id * 'a) Container.t (* The inner generator of fresh identifiers: *) let fresh = match Fresh.fresh with | None -> let c = Counter.create () in Counter.fresh c | Some f -> f (* Common identical functions: *) let create = Container.create let clear = Container.clear let copy = Container.copy let is_empty = Container.is_empty let rev = Container.rev let rev_copy = Container.rev_copy let length = Container.length let is_empty = Container.is_empty let length = Container.length let rev = Container.rev let rev_copy = Container.rev_copy (* Functions with the same name but abstracting from identifiers: *) let pop t = snd (Container.pop t) let top t = snd (Container.top t) let iter f = Container.iter (fun (_,x) -> f x) let filter f = Container.filter (fun (_,x) -> f x) let map f = Container.map (fun (id,x) -> (id,f x)) let fold f = Container.fold (fun b (id,x) -> f b x) let to_list t = List.map snd (Container.to_list t) let of_list xs = Container.of_list (List.map (fun x -> (fresh ()),x) xs) (* Identical functions but changing name ("i" suffix): *) let pushi = Container.push let copushi = Container.copush let popi = Container.pop let topi = Container.top let iteri = Container.iter let filteri = Container.filter let mapi = Container.map let foldi = Container.fold let to_assoc_list = Container.to_list let of_assoc_list = Container.of_list (* Push and co: *) let push x t = let id = fresh () in let () = Container.push (id,x) t in id let copush t x = let id = fresh () in let () = Container.copush t (id,x) in id (* Now the two functions that represent the real purpose of having identifiers: *) exception Found let get_by_id id t = let result = ref None in try Container.iter (fun (j,x) -> if j = id then (result := Some x; raise Found)) t; raise Not_found with Found -> Option.extract (!result) let remove_by_id id = Container.filter (fun (j,_) -> j<>id) module Fresh = struct let fresh = Some fresh end end module Stack_with_identifiers = Add_identifiers (struct let fresh=None end) (StackExtra) module Queue_with_identifiers = Add_identifiers (struct let fresh=None end) (struct include Queue include QueueExtra end) ocamlbricks-0.90+bzr456.orig/STRUCTURES/cache.mli0000644000175000017500000000321113175721005020211 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Build a cached version of a function working on a non-persistent structure. The structure must be equipped with a revision number: this integer is used to decide when the function has to be recalculated or when the value stored in the cache may be taken as the result of the function. {b Example}: {[ (* The module implementing the data structure has to manage a revision number, as for instance Cloakroom: *) # let t = Cloakroom.create () ;; val t : '_a Cloakroom.t = # let to_list = Cache.optimize ~revision:Cloakroom.revision Cloakroom.to_list t ;; val to_list : '_a list Cache.thunk = # to_list () ;; : '_a list = [] # Cloakroom.add t "foo" ;; : Cloakroom.id = 1 # Cloakroom.add t "bar" ;; : Cloakroom.id = 2 # Cloakroom.revision t;; : int = 2 # to_list () ;; : string list = ["foo"; "bar"] ]} *) val optimize : revision:('t -> int) -> ('t -> 'a) -> 't -> unit -> 'a ocamlbricks-0.90+bzr456.orig/STRUCTURES/string_queue.ml0000644000175000017500000001200713175721005021512 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF (* Each string in the queue comes with its real size <= block_size. *) type t = { writer_mutex : Mutex.t ; (* writers are queue producers. *) block_size : int ; mutable total_size : int ; queue : (string * int) Queue.t ; released : unit Egg.t; reader_mutex : Mutex.t ; (* The first reader is also the producer of the catenation. *) mutable catenation : string option; } (** Create a string queue. The optional [?block_size=8192] set the size of each string buffer in the queue. *) let create ?(block_size=8192) () = { writer_mutex = Mutex.create (); reader_mutex = Mutex.create (); block_size = block_size; total_size = 0; queue = Queue.create (); released = Egg.create () ; catenation = None ; } (** The type of the standard [String.blit]. *) type blit_function = string -> int -> string -> int -> int -> unit (** Thread-unsafe versions. If you are not using threads this is the module for you. *) module Thread_unsafe = struct (** Import the content of the [Unix] file descriptor into a string queue. *) let append_from_descr ?(release=true) t (fd:Unix.file_descr) : unit = if t.catenation <> None then failwith "String_queue.Thread_unsafe.append_from_descr: queue already consumed (catenated)." else begin let block_size = t.block_size in let current_size = t.total_size in let q = t.queue in let buff = Bytes.create block_size in let rec loop acc_n = begin let n = (Unix.read fd buff 0 block_size) in if (n=0) then acc_n else ((Queue.push ((String.sub buff 0 n),n) q); loop (acc_n + n)) end in let dst_size = loop current_size in (t.total_size <- dst_size); (if release then (Egg.release t.released ()) else ()); end (** Efficient concatenation of the string queue content. The queue internal queue is then destructively emptied but the result of catenation remains available for other readers. *) let concat ?(blit:blit_function=String.blit) t : string = match t.catenation with | Some s -> s | None -> begin let dst_size = t.total_size in let q = t.queue in let dst = Bytes.create dst_size in let rec loop dstoff = if dstoff>=dst_size then () else begin let (src,src_size) = Queue.take q in (blit src 0 dst dstoff src_size); loop (dstoff+src_size) end in (loop 0); (t.catenation <- Some dst); dst end end (* Mutex equipped by with_mutex. *) module Mutex = MutexExtra.Extended_Mutex (** Append the content of the [Unix] file descriptor into a string queue. By default, the queue is built then released [?(release=true)], then is ready to be catenated by a reader. *) let append_from_descr ?(release=true) t (fd:Unix.file_descr) : unit = Mutex.with_mutex t.writer_mutex (fun () -> Thread_unsafe.append_from_descr ~release t fd) (** Import the content of the [Unix] file descriptor into a string queue. *) let from_descr ?(release=true) ?(block_size=8192) (fd:Unix.file_descr) : t = let result = create ~block_size () in (Thread_unsafe.append_from_descr ~release result fd); result (** Similar to {!String_queue.from_descr}) but the user provides the file name instead of the file descriptor. *) let from_file ?(release=true) ?(block_size=8192) (filename:string) : t = let fd = (Unix.openfile filename [Unix.O_RDONLY;Unix.O_RSYNC] 0o640) in let result = from_descr ~release ~block_size fd in (Unix.close fd); result (** Similar to {!String_queue.from_descr}) but the user provides the [Pervasives.in_channel] instead of the file descriptor. *) let from_channel ?(release=true) ?(block_size=8192) in_channel : t = from_descr ~release ~block_size (Unix.descr_of_in_channel in_channel) (** Efficient concatenation of the string queue content. The catenation is performed by the first reader when the queue is released by a writer. If a successive reader requires the catenation, it will get it immediately. *) let concat ?(blit:blit_function=String.blit) t : string = let () = Egg.wait t.released in Mutex.with_mutex t.reader_mutex (fun () -> Thread_unsafe.concat ~blit t) ocamlbricks-0.90+bzr456.orig/STRUCTURES/hashmmap.ml0000644000175000017500000001441713175721005020605 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo Copyright (C) 2008 Luca Saiu (wrote the methods remove_key_value_or_fail and remove_key_value) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** The default size of the hash used in the implementation *) let default_size = 251;; (** The hashmultimap class *) class ['a,'b] hashmultimap = fun ?(size=default_size) () -> object (self) (** The state of the hashmap. *) val current : ('a,'b) Hashtbl.t = (Hashtbl.create size) method get = current (** Return all the objects bound to the given key, or raise Not_found: *) method lookup_or_fail x = (Hashtbl.find_all current x) (** Return all the objects bound to the given key, or the empty list if no binding is found: *) method lookup x = try self#lookup_or_fail x with Not_found -> [] (** Answer (quickly!) to the question if (x,y) is a member of the (multi) map. *) method mem x y : bool = try List.mem y (Hashtbl.find_all current x) with Not_found -> false (** Answer (quickly!) to the question if (x,y) is a member of the (multi) map. *) method memq x y : bool = try List.memq y (Hashtbl.find_all current x) with Not_found -> false (** Answer if x is bound in the multi map. *) method bound x = Hashtbl.mem current x (** Add a binding to a multi map. A key may be associated to several values, but at most one occurrence of a same binding (key, value) will be stored. This semantics should be the only relevant difference with standard hash tables (Hashtbl). *) method add x y = if self#mem x y then () (* don't repeat the same binding several times in the structure *) else (Hashtbl.add current x y) (** Replace or add (when not existing) a binding to a multi map. *) method replace x y = (self#remove ~all:true x); Hashtbl.add current x y (** Remove one or all (default) bindings of the given key. *) method remove ?(all=true) x = if all then let rm1binding = (fun k v -> if k=x then (Hashtbl.remove current k) else ()) in Hashtbl.iter rm1binding current else (Hashtbl.remove current x) (** Remove the given binding, if present; otherwise do nothing. *) method remove_key_value key value = let old_values_for_key = self#lookup key in let new_values_for_key = List.filter (fun a_value -> not (value = a_value)) old_values_for_key in let new_bindings_for_key = List.rev (* We reverse as we want to keep the previous element 'priority' *) (List.map (fun a_value -> key, a_value) new_values_for_key) in self#remove ~all:true key; List.iter (fun (new_key, new_value) -> self#add new_key new_value) new_bindings_for_key (** Remove the given binding, if present; otherwise raise an exception. *) method remove_key_value_or_fail key value = let old_values_for_key_no = List.length (self#lookup key) in self#remove_key_value key value; if not ((List.length (self#lookup key)) = (old_values_for_key_no - 1)) then begin failwith "remove_key_value_or_fail did not remove *one* element"; end (** Make an alist from the map, returning the bindings as pairs in some unspecified order. *) method to_list = Hashtbl.fold (fun a b current_list -> (a, b) :: current_list) current [] (** Add all the binding from the given alist to the map. *) method add_list alist = ignore (List.map (fun (key, datum) -> self#add key datum) alist) end;; (* class hashmultimap *) (* Functional interface. *) (** The abstract type of an hashmmap. *) type ('a,'b) t = ('a,'b) hashmultimap ;; (** The hashmmap constructor. *) let make ?(size=default_size) () : ('a,'b) t = new hashmultimap ~size () ;; (** Return all the objects bound to the given key, or raise Not_found: *) let lookup_or_fail (h:('a,'b) t) x = h#lookup_or_fail x;; (** Return all the objects bound to the given key, or the empty list if no binding is found: *) let lookup (h:('a,'b) t) x = h#lookup x;; (** The member predicate. *) let mem (h:('a,'b) t) (x:'a) (y:'b) = h#mem x y;; (** The member predicate with the physical equality. *) let memq (h:('a,'b) t) (x:'a) (y:'b) = h#memq x y;; (** Answer if x is bound in the multi map. *) let bound (h:('a,'b) t) (x:'a) = h#bound x ;; (** Add a binding to the hashmmap. *) let add (h:('a,'b) t) (x:'a) (y:'b) = h#add x y;; (** Add all the binding from the given alist to the map. *) let add_list (h:('a,'b) t) (alist:('a * 'b) list) = h#add_list alist;; (** [replace h x y] removes all bindings in [h] for the key [x], then add the binding [(x,y)]. *) let replace (h:('a,'b) t) (x:'a) (y:'b) = h#replace x y;; (** Remove one or all (default) bindings of the given key. *) let remove (h:('a,'b) t) ?(all=true) (x:'a) = h#remove ~all x;; (** [update ~replace t1 t2] updates the map [t1] adding (by calling [add]) all the bindings from [t2]. If the flag [replace] is [true], all existing keys in [t2] are removed from [t1] before insertions take place.*) let update ?(replace=false) (h1:('a,'b) t) (h2:('a,'b) t) : unit = (if replace then Hashtbl.iter (fun x y ->h1#remove x) (h2#get)) ; Hashtbl.iter (h1#add) (h2#get) ;; (** Make an alist from an hashmmap, returning the bindings as pairs in some unspecified order. *) let to_list (h:('a,'b) t) = h#to_list;; (** Make a new hashmmap from an alist made of pairs. *) let of_list ?size:(size=default_size) alist = let h : ('a,'b) t = new hashmultimap ~size () in ignore (List.map (fun (key, datum) -> h#add key datum) alist); h;; ocamlbricks-0.90+bzr456.orig/STRUCTURES/container.mli0000644000175000017500000001013213175721005021130 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** The signature of an imperative stack or queue *) module type T = sig type 'a t val create : unit -> 'a t val clear : 'a t -> unit val copy : 'a t -> 'a t val push : 'a -> 'a t -> unit val pop : 'a t -> 'a val top : 'a t -> 'a val is_empty : 'a t -> bool val length : 'a t -> int val iter : ('a -> unit) -> 'a t -> unit val filter : ('a -> bool) -> 'a t -> unit val map : ('a -> 'a) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val rev : 'a t -> unit val rev_copy : 'a t -> 'a t val to_list : 'a t -> 'a list val of_list : 'a list -> 'a t (** The push method in the opposite discipline: if the container is LIFO the co-pushing method is FIFO and vice-versa. For instance, in a stack implemented by a list, the co-pushing method is the `append' operation: push x xs = x::xs copush xs x = xs@[x] In other words, the co-pushing method is the composition: reverse; push; reverse *) val copush : 'a t -> 'a -> unit end module type T_with_identifiers = sig type id = int type 'a t (* Functions with the same name but abstracting from identifiers: *) val create : unit -> 'a t val clear : 'a t -> unit val copy : 'a t -> 'a t val pop : 'a t -> 'a val top : 'a t -> 'a val is_empty : 'a t -> bool val length : 'a t -> int val iter : ('a -> unit) -> 'a t -> unit val filter : ('a -> bool) -> 'a t -> unit val map : ('a -> 'a) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val rev : 'a t -> unit val rev_copy : 'a t -> 'a t val to_list : 'a t -> 'a list val of_list : 'a list -> 'a t (* There are two differences with the T signature about shared names: both `push' and `copush' return the `id' generated for insertion: *) val push : 'a -> 'a t -> id val copush : 'a t -> 'a -> id (* Identical functions but changing name ("i" suffix or "assoc_"): *) val pushi : (id * 'a) -> 'a t -> unit val copushi : 'a t -> (id * 'a) -> unit val popi : 'a t -> id * 'a val topi : 'a t -> id * 'a val iteri : (id * 'a -> unit) -> 'a t -> unit val filteri : (id * 'a -> bool) -> 'a t -> unit val mapi : (id * 'a -> id * 'a) -> 'a t -> unit val foldi : ('b -> id * 'a -> 'b) -> 'b -> 'a t -> 'b val to_assoc_list : 'a t -> (id * 'a) list val of_assoc_list : (id * 'a) list -> 'a t (* The real purpose of having identifiers: *) (* get_by_id may raise [Not_found] *) val get_by_id : id -> 'a t -> 'a (* Does nothing if the id doesn't exist: *) val remove_by_id : id -> 'a t -> unit (* The inner generator of fresh identifiers: *) val fresh : unit -> int (* The inner generator of fresh identifiers *as module* (useful to have something ready to be provided to a functor). (Note that fresh = Option.extract Fresh.fresh) *) module Fresh : sig val fresh : (unit -> int) option end end module Add_identifiers : (* Fresh is morally an optional functor argument: *) functor (Fresh : sig val fresh : (unit -> int) option end) -> functor (Container: T) -> T_with_identifiers module Stack_with_identifiers : T_with_identifiers module Queue_with_identifiers : T_with_identifiers ocamlbricks-0.90+bzr456.orig/STRUCTURES/rev.mli0000644000175000017500000000321013175721005017741 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Reversible references. The operation [open_parenthesis] set a backtracking point: all settings to reversible references could be reset by a simple call to [close_parenthesis]. The user can nest parenthesis as he wishes. {b Example}: {[# let x = create 42 ;; val x : int t = {previous = []; current = 42} # set x 43 ;; : unit = () # open_parenthesis () ;; : unit = () # set x 44 ;; : unit = () # set x 45 ;; : unit = () # get x;; : int = 45 # close_parenthesis () ;; : unit = () # get x;; : int = 43 # back_parenthesis () ;; : unit = () # get x;; : int = 42 ]} *) type 'a t val create : 'a -> 'a t val open_parenthesis : unit -> unit val close_parenthesis : unit -> unit val back_parenthesis : unit -> unit val get : 'a t -> 'a val set : 'a t -> 'a -> unit (** {2 Toolkit} *) module Toolkit : sig val ref : 'a -> 'a t val (!) : 'a t -> 'a val (:=) : 'a t -> 'a -> unit end ocamlbricks-0.90+bzr456.orig/STRUCTURES/cortex_lib.ml0000644000175000017500000003451313175721005021140 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) module Process = struct type program = string type arguments = string list type pid = int type birthtime = float (* since 00:00:00 GMT, Jan. 1, 1970, in seconds *) type age = float (* duration, in seconds *) type exit_code = int type signal_name = string type mrproper = unit -> unit (* to close channels *) (* Process options: *) type options = { mutable stdin : Endpoint.Source.t; mutable stdout : Endpoint.Sink.t; mutable stderr : Endpoint.Sink.t; mutable pseudo : string option; } let make_defaults () = { stdin = Endpoint.Source.Empty; stdout = Endpoint.Sink.Trash; stderr = Endpoint.Sink.Trash; pseudo = None; } let make_options ?enrich ?stdin ?stdout ?stderr ?pseudo () = let t = match enrich with None -> make_defaults () | Some t -> t in Option.iter (fun x -> t.stdin <- x) stdin; Option.iter (fun x -> t.stdout <- x) stdout; Option.iter (fun x -> t.stderr <- x) stderr; Option.iter (fun x -> t.pseudo <- Some x) pseudo; t type tuning = unit -> options module State = struct type running_state = | Running | Suspended type t = | Planned of tuning * program * arguments | Started of program * birthtime * pid * mrproper * running_state | Terminated of program * age * pid * (signal_name, exit_code) Either.t (* Mrproper is a pain, the standard equality will raise an exception (functional value), so it must be redefined: *) let equality x y = match (x,y) with | Started (n,d,p,_,r), Started (n',d',p',_,r') -> (n=n') && (d=d') && (p=p') && (r=r') | Started (_,_,_,_,_), _ | _, Started (_,_,_,_,_) -> false (* tuning is also a pain: *) | Planned (t,n,a) , Planned (t',n',a') -> (t==t') && (n=n') && (a=a') | x,y -> x=y let is_planned = function | Planned (_,_,_) -> true | _ -> false let is_started = function | Started (_,_,_,_,_) -> true | _ -> false let is_suspended = function | Started (_,_,_,_, Suspended) -> true | _ -> false let is_not_suspended = function | Started (_,_,_,_, Suspended) -> false | _ -> true let is_running = function | Started (_,_,_,_, Running) -> true | _ -> false let is_terminated = function | Terminated (_,_,_,_) -> true | _ -> false let is_terminated_and_has_been_really_executed = function | Terminated (program, _, pid, Either.Right (127)) when not (UnixExtra.is_executable program) -> false | Terminated (_,_,_,_) -> true | _ -> false let is_terminated_aged_at_least ~seconds = if seconds < 0. then invalid_arg "Process.State.is_terminated_aged_at_least: negative age" else function | Terminated (_, age, _,_) -> (age >= seconds) | _ -> false let birthtime = function | Started (_,birthtime,_,_,_) -> Some birthtime | _ -> None let age = function | Terminated (_, age, _,_) -> Some age | _ -> None end (* Process.State *) type t = State.t Cortex.t type u = State.t Cortex.u module Open = struct let plan ?(tuning = fun () -> make_options ()) (program:string) (arguments:string list) : u = (* Set some transitions as forbidden (for instance, when terminal states are reached): *) let on_proposal s0 s1 = match (s0,s1) with | State.Terminated (_,_,_,_) , _ -> s0 | State.Started (_,_,_,_,_) , State.Planned (_,_,_) -> s0 | _, _ -> s1 in Cortex.Open.return ~equality:State.equality ~on_proposal (State.Planned (tuning, program, arguments)) end (* module Open *) let plan ?tuning program arguments : t = Cortex.Open.close (Open.plan ?tuning program arguments) (* Is a cortex evaluation, so it propose a transition that may be accepted or not, as may be observable by the caller in the result: *) let start t : (State.t * bool) = let transition = function | State.Planned (tuning, program, arguments) -> let t = tuning () in let (stdin, stdin_must_be_closed ) = Endpoint.Source.to_file_descr t.stdin in let (stdout, stdout_must_be_closed) = Endpoint.Sink.to_file_descr t.stdout in let (stderr, stderr_must_be_closed) = Endpoint.Sink.to_file_descr t.stderr in let name = match t.pseudo with None -> program | Some name -> name in let argv = (Array.of_list (name :: arguments)) in (* Channels' treatment: *) let mrproper () = begin (if stdin_must_be_closed then try Unix.close stdin with _ -> ()); (if stdout_must_be_closed then try Unix.close stdout with _ -> ()); (if stderr_must_be_closed then try Unix.close stderr with _ -> ()); end in let birthtime = Unix.time () in let pid = Unix.create_process program argv stdin stdout stderr in State.Started (program, birthtime, pid, mrproper, State.Running) | state -> state in (* end of transition() *) (* main of start() *) let (state', changed) = Cortex.move t transition in let () = if not changed then () else match state' with | State.Started (program, birthtime, pid, mrproper, State.Running) -> let _thread = ThreadExtra.waitpid_thread (* --- *) ~perform_when_suspended: (fun ~pid -> Cortex.set t (State.Started (program, birthtime, pid, mrproper, State.Suspended))) (* --- *) ~perform_when_resumed: (fun ~pid -> Cortex.set t (State.Started (program, birthtime, pid, mrproper, State.Running))) (* --- *) ~after_waiting: (fun ~pid status -> let () = mrproper () in let exiting_info = match status with | Unix.WSIGNALED signal -> Either.Left (SysExtra.name_of_signal signal) | Unix.WEXITED code -> Either.Right code | _ -> assert false in let age = (Unix.time ()) -. birthtime in Cortex.set t (State.Terminated (program, age, pid, exiting_info))) (* --- *) () ~pid in () | _ -> () in (state', changed) let suspend ?nohang t : (State.t * bool) = let action = function | State.Started (_,_,pid,_, State.Running) as state -> (Unix.kill pid Sys.sigstop; state) | state -> state in let state = Cortex.apply t action in (* Now wait until the pause will be observed: *) let (state, changed) = match (State.is_running state) && (nohang = None) with | true -> (Cortex.get ~guard:State.is_suspended t, true) | false -> (state, false) in (state, changed) let resume ?nohang t : (State.t * bool) = let action = function | State.Started (_,_,pid,_, State.Suspended) as state -> (Unix.kill pid Sys.sigcont; state) | state -> state in let state = Cortex.apply t action in (* Now wait until the pause will be observed: *) let (state, changed) = match (State.is_suspended state) && (nohang = None) with | true -> (Cortex.get ~guard:State.is_not_suspended t, true) | false -> (state, false) in (state, changed) let rec terminate ?nohang ?sigkill t : (State.t * bool) = let term = if sigkill = Some () then Sys.sigkill else Sys.sigterm in let action = function | State.Started (_,_,pid,_, State.Running) as state -> (Unix.kill pid term; state) | State.Started (_,_,pid,_, State.Suspended) as state -> (List.iter (Unix.kill pid) [term; Sys.sigcont]; state) | state -> state in let state = Cortex.apply t action in let () = if sigkill = None then ignore (Thread.create (fun () -> Thread.delay 0.5; terminate ~sigkill:() t) ()) else () in (* Now wait until the pause will be observed: *) let (state, changed) = match (State.is_started state) && (nohang = None) with | true -> (Cortex.get ~guard:State.is_terminated t, true) | false -> (state, false) in (state, changed) (* Redefinition: *) let terminate ?nohang t = terminate ?nohang ?sigkill:None t class c ?tuning (program:string) (arguments:string list) = let t = plan ?tuning program arguments in object inherit [State.t] Cortex.Object.with_private_interface t method start : unit -> State.t * bool = fun () -> start t method suspend : ?nohang:unit -> unit -> State.t * bool = fun ?nohang () -> suspend ?nohang t method resume : ?nohang:unit -> unit -> State.t * bool = fun ?nohang () -> resume ?nohang t method terminate : ?nohang:unit -> unit -> State.t * bool = fun ?nohang () -> terminate ?nohang t end end (* module Process *) module Service = struct type t = ((Process.State.t option) * Process.t) Cortex.t let plan ?tuning (program:string) (arguments:string list) : t = let creator ?previous () = Process.Open.plan ?tuning program arguments in let terminal = Process.State.is_terminated in Cortex.lifes ~creator ~terminal () let start (t:t) : (Process.State.t * bool) = Cortex.apply t (fun (_,p) -> Process.start p) let status (t:t) : Process.State.t = Cortex.apply t (fun (_,p) -> Cortex.get p) let previous_status (t:t) : Process.State.t option = Cortex.apply t (fun (s,_) -> s) let previous_really_executed (t:t) : bool = Cortex.apply t (fun (s,_) -> match s with | None -> false | Some state -> Process.State.is_terminated_and_has_been_really_executed state ) let previous_aged_at_least ~seconds (t:t) : bool = Cortex.apply t (fun (s,_) -> match s with | None -> false | Some state -> Process.State.is_terminated_aged_at_least ~seconds state ) let previous_age (t:t) : float option = Cortex.apply t (fun (s,_) -> Option.bind s (Process.State.age)) let status (t:t) : Process.State.t = Cortex.apply t (fun (_,p) -> Cortex.get p) let stop ?nohang (t:t) : (Process.State.t * bool) = Cortex.apply t (fun (_,p) -> Process.terminate ?nohang p) let suspend (t:t) : (Process.State.t * bool) = Cortex.apply t (fun (_,p) -> Process.suspend p) let resume ?nohang (t:t) : (Process.State.t * bool) = Cortex.apply t (fun (_,p) -> Process.resume ?nohang p) (* (* Supposing recursive mutexes here (start t) in the critical section: *) let restart (t:t) : (Process.State.t * bool) = Cortex.apply t (fun (_,p) -> let (_, changed) as stop_result = Process.terminate p in if not changed then stop_result else start t)*) (* Without recursive mutexes we can break the critical section but it's not the same because another thread may start the service... *) let restart (t:t) : (Process.State.t * bool) = let (_, changed) as stop_result = stop t in if not changed then stop_result else start t class c ?tuning (program:string) (arguments:string list) = let t = plan ?tuning program arguments in object inherit [Process.State.t option * Process.t] Cortex.Object.with_private_interface t method start : unit -> Process.State.t * bool = fun () -> start t method previous_status : unit -> Process.State.t option = fun () -> previous_status t method previous_really_executed : unit -> bool = fun () -> previous_really_executed t method previous_aged_at_least : seconds:float -> bool = fun ~seconds -> previous_aged_at_least ~seconds t method previous_age : unit -> float option = fun () -> previous_age t method status : unit -> Process.State.t = fun () -> status t method suspend : unit -> Process.State.t * bool = fun () -> suspend t method resume : ?nohang:unit -> unit -> Process.State.t * bool = fun ?nohang () -> resume ?nohang t method stop : ?nohang:unit -> unit -> Process.State.t * bool = fun ?nohang () -> stop ?nohang t method restart : unit -> Process.State.t * bool = fun () -> restart t end end (* module Service *) module Channel = struct (* The channel may be empty or it may contain a message for someone *) type 'a t = ('a option) Cortex.t let return ?equality ?on_proposal ?on_commit ?init () = let equality = match equality with | None -> None | Some f -> Some (fun xo yo -> match xo,yo with | None, None -> true | Some x, Some y -> f x y | _,_ -> false) in Cortex.return ?equality ?on_proposal ?on_commit init let receive (t:'a t) : 'a = let (result, _changed) = Cortex.eval ~guard:(fun v -> v<>None) (fun v () -> match v with | Some msg -> (None, (fun _ -> msg)) | None -> assert false) () t in result let send (t:'a t) (msg:'a) : bool = let (result, changed) = Cortex.eval ~guard:(fun v -> v=None) (fun v () -> match v with | None -> (Some msg), (fun _accepted -> ()) | Some _ -> assert false) () t in changed end (* Canal *) module Clock = struct (* Just a counter incremented by an hidden thread. *) type t = int Cortex.t let make ?(init=0) ?limit ?(delay=1.) () = let result = Cortex.return init in let _orbiter = let terminate = match limit with | None -> (fun i -> false) | Some limit -> ((=)limit) in let rec loop i = if terminate i then () else (* continue: *) let () = Thread.delay delay in let i = i + 1 in (* val Cortex.move : ?guard:('a -> bool) -> 'a t -> ('a -> 'a) -> 'a * bool *) let _ = Cortex.move result (fun j -> j+1) in (* let () = Cortex.set result i in *) loop i in Thread.create loop init in result end (* Clock *) ocamlbricks-0.90+bzr456.orig/STRUCTURES/network.ml0000644000175000017500000014222213175721005020474 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2011, 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF module Log = Ocamlbricks_log exception Accepting of exn exception Connecting of exn exception Receiving of exn exception Sending of exn exception Closing of exn exception Binding of exn type tutoring_thread_behaviour = ThreadExtra.Easy_API.options let string_of_sockaddr = function | Unix.ADDR_UNIX x -> x | Unix.ADDR_INET (inet_addr, port) -> Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet_addr) port (** Extract the name of the associated socket file from a unix domain sockaddr. Raises [Invalid_argument] if the sockaddr is not in the unix domain. *) let socketfile_of_sockaddr = function | Unix.ADDR_UNIX x -> x | _ -> invalid_arg "Network.socketfile_of_sockaddr" (** Extract the inet_addr and port from a inet domain sockaddr. Raises [Invalid_argument] if the sockaddr is not in the inet domain. *) let inet_addr_and_port_of_sockaddr = function | Unix.ADDR_INET (inet_addr, port) -> (inet_addr, port) | _ -> invalid_arg "Network.inet_addr_of_sockaddr" let domain_of_inet_addr x = Unix.domain_of_sockaddr (Unix.ADDR_INET (x, 0)) let string_of_domain = function | Unix.PF_UNIX -> "Unix domain" | Unix.PF_INET -> "Internet domain (IPv4)" | Unix.PF_INET6 -> "Internet domain (IPv6)" (* Inspired by the homonymous function in the standard library unix.ml *) let rec accept_non_intr s = try Unix.accept s with | Unix.Unix_error (Unix.EINTR, _, _) -> accept_non_intr s | e -> raise (Accepting e) let accept_in_range_non_intr ~(range_predicate : Unix.sockaddr -> bool) ~(range_string : string) s = let rec loop () = try let (service_socket, _) as result = Unix.accept s in let sockaddr0 = (Unix.getsockname service_socket) in if range_predicate sockaddr0 then result else begin Log.printf2 "Rejecting a connexion from %s (not in the range %s)\n" (string_of_sockaddr sockaddr0) range_string; Unix.close service_socket; loop () end with | Unix.Unix_error (Unix.EINTR, _, _) -> loop () | e -> raise (Accepting e) in loop () module Ipv4_or_ipv6 = struct (** Convert a predicate about a string (representing an IPv4 or an IPv6 address) into a predicate about a Unix.sockaddr *) let sockaddr_predicate_of_ip_predicate (pred : ip:string -> bool) : (Unix.sockaddr -> bool) = function | Unix.ADDR_UNIX _ -> false | Unix.ADDR_INET (inet_addr, port) -> let ip = (Unix.string_of_inet_addr inet_addr) in pred ~ip let range_predicate_of (config:string) : (Unix.sockaddr -> bool) = match Option.apply_or_catch (fun config -> Ipv4.String.ipcalc ~config) config with | Some result -> sockaddr_predicate_of_ip_predicate (result#contains) | None -> begin match Option.apply_or_catch (fun config -> Ipv6.String.ipcalc ~config) config with | Some result -> sockaddr_predicate_of_ip_predicate (result#contains) | None -> invalid_arg ("invalid range: "^config) end end let switch_between_accepting_functions = function | None -> accept_non_intr | Some config -> let range_predicate = Ipv4_or_ipv6.range_predicate_of config in accept_in_range_non_intr ~range_predicate ~range_string:config (* Unix.bind wrapper: raises the exception Binding if something goes wrong: *) let bind socket sockaddr = try Unix.bind socket sockaddr with e -> let (inet_addr, port) = inet_addr_and_port_of_sockaddr sockaddr in let domain = string_of_domain (domain_of_inet_addr inet_addr) in Log.print_exn ~prefix:(Printf.sprintf "binding socket to %s address %s: " domain (string_of_sockaddr sockaddr)) e; raise (Binding e) (* fix Unix.IPV6_ONLY if needed *) let fix_IPV6_ONLY_if_needed ~domain fd = if domain <> Unix.PF_INET6 then () else let ipv6_only = Unix.getsockopt fd Unix.IPV6_ONLY in (if not ipv6_only then Log.printf "Fixing option Unix.IPV6_ONLY to true\n"; Unix.setsockopt fd Unix.IPV6_ONLY true); () (* Generic function able to establish a server on a sockaddr. *) let server ?(max_pending_requests=5) ?seqpacket ?tutor_behaviour ?no_fork ?range server_fun sockaddr = let accepting_function = switch_between_accepting_functions range in let socket_type = match seqpacket with | None -> Unix.SOCK_STREAM | Some () -> Unix.SOCK_SEQPACKET (* implies domain = Unix.ADDR_UNIX *) in let domain = Unix.domain_of_sockaddr sockaddr in let listen_socket = Unix.socket domain socket_type 0 in (* listen_socket initialization: *) let assigned_port = Unix.setsockopt listen_socket Unix.SO_REUSEADDR true; fix_IPV6_ONLY_if_needed ~domain listen_socket; bind listen_socket sockaddr; Unix.listen listen_socket max_pending_requests; (* The assigned port will be interesting for the caller only if the port number provided with ~sockaddr has been set to 0 (in order to ask the kernel to choose itself): *) match Unix.getsockname listen_socket with | Unix.ADDR_INET (_, assigned_port) -> Some assigned_port | Unix.ADDR_UNIX socketfile -> let () = Unix.chmod socketfile 0o777 in None in let listen_socket_as_string = string_of_sockaddr (Unix.getsockname listen_socket) in let notify_after_accept_and_get_sockaddr0 ~connexion_no ~service_socket = incr connexion_no; let sockaddr0 = string_of_sockaddr (Unix.getsockname service_socket) in let sockaddr1 = string_of_sockaddr (Unix.getpeername service_socket) in Log.printf3 "Accepted connection #%d on %s from %s\n" !connexion_no sockaddr0 sockaddr1; sockaddr0 in let exit_code_and_final_notification ~connexion_no ~sockaddr0 ~result = match result with | Either.Right () -> let () = Log.printf2 "Protocol completed (connection #%d on %s). Exiting.\n" !connexion_no sockaddr0 in 0 | Either.Left _ -> let () = Log.printf2 "Protocol interrupted (connection #%d on %s). Exiting\n" !connexion_no sockaddr0 in 1 in let process_forking_loop () = let connexion_no = ref 0 in let tutor = ThreadExtra.Easy_API.waitpid_thread ?options:tutor_behaviour () in while true do Log.printf1 "Waiting for connection on %s\n" listen_socket_as_string; let (service_socket, _) = accepting_function listen_socket in let sockaddr0 = notify_after_accept_and_get_sockaddr0 ~connexion_no ~service_socket in match Unix.fork () with | 0 -> (* The child here: *) begin try Log.printf2 "Process (fork) created for connection #%d on %s\n" !connexion_no sockaddr0; (* SysExtra.log_signal_reception ~except:[26] (); *) Unix.close listen_socket; (try Unix.set_close_on_exec service_socket with Invalid_argument _ -> ()); let result = server_fun service_socket in let exit_code = exit_code_and_final_notification ~connexion_no ~sockaddr0 ~result in exit exit_code with e -> (Log.printf3 "Process (fork) created for connection #%d on %s: terminated with exn: %s\n" !connexion_no sockaddr0 (Printexc.to_string e); exit 4) end | child_pid -> (* The father here creates a process-tutor thread per child: *) begin Unix.close service_socket; ignore (tutor child_pid) end done in let thread_forking_loop () = let connexion_no = ref 0 in while true do let (service_socket, _) = accepting_function listen_socket in let sockaddr0 = notify_after_accept_and_get_sockaddr0 ~connexion_no ~service_socket in let server_fun s = Log.printf2 "Thread created for connection #%d on %s\n" !connexion_no sockaddr0; let result = server_fun s in let _unused_exit_code = exit_code_and_final_notification ~connexion_no ~sockaddr0 ~result in Thread.exit () in ignore (ThreadExtra.create server_fun service_socket); done in let forking_loop () = (* Provide to the other threads a mean to kill this forking_loop: *) let () = let shutdown () = Unix.shutdown listen_socket Unix.SHUTDOWN_RECEIVE in ThreadExtra.set_killable_with_thunk (fun () -> shutdown ()) in (* listen_socket finalization: *) let () = match sockaddr with | Unix.ADDR_UNIX filename -> ThreadExtra.at_exit (fun () -> Unix.unlink filename) | _ -> () in (* process or thread switching: *) match no_fork with | None -> process_forking_loop () | Some () -> thread_forking_loop () in let server_thread = ThreadExtra.create forking_loop () in (server_thread, assigned_port) let socketname_in_a_fresh_made_directory ?temp_dir ?prefix ?suffix ?(perm=0o777) basename = let prefix = match prefix with | Some x -> x | None -> Printf.sprintf ".%s-%d.%d-sockets-" (Filename.basename (Sys.executable_name)) (Unix.getpid ()) (Thread.id (Thread.self ())) in let fresh_made_dir = FilenameExtra.temp_dir ?temp_dir ~prefix ?suffix ~perm () in let result = (String.concat "/" [fresh_made_dir; basename]) in let () = ThreadExtra.at_exit (fun () -> Unix.rmdir fresh_made_dir) in let () = ThreadExtra.at_exit (fun () -> Unix.unlink result) in result let fresh_socketname ?temp_dir ?prefix ?(suffix="") () = let prefix = match prefix with | Some x -> x | None -> Printf.sprintf ".%s-%d.%d-socket-" (Filename.basename (Sys.executable_name)) (Unix.getpid ()) (Thread.id (Thread.self ())) in let result = Filename.temp_file ?temp_dir prefix suffix in let () = Unix.unlink result in let () = ThreadExtra.at_exit (fun () -> Unix.unlink result) in result let unix_server ?max_pending_requests ?seqpacket ?tutor_behaviour ?no_fork ?socketfile server_fun = let socketfile = Option.extract_or_force socketfile (lazy (socketname_in_a_fresh_made_directory "ctrl")) in let sockaddr = Unix.ADDR_UNIX socketfile in let (server_thread, _) = server ?max_pending_requests ?seqpacket ?tutor_behaviour ?no_fork server_fun sockaddr in (server_thread, socketfile) let inet4_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?(port=0) server_fun = let ipv4 = match ipv4 with | Some x -> Unix.inet_addr_of_string x | None -> Unix.inet_addr_any in let sockaddr = Unix.ADDR_INET (ipv4, port) in let (server_thread, assigned_port) = server ?max_pending_requests ?tutor_behaviour ?no_fork ?range:range4 server_fun sockaddr in let assigned_port = match assigned_port with | Some x -> x | None -> assert false in (server_thread, (Unix.string_of_inet_addr ipv4), assigned_port) let inet6_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?(port=0) server_fun = let ipv6 = match ipv6 with | Some x -> Unix.inet_addr_of_string x | None -> Unix.inet6_addr_any in let sockaddr = Unix.ADDR_INET (ipv6, port) in let (server_thread, assigned_port) = server ?max_pending_requests ?tutor_behaviour ?no_fork ?range:range6 server_fun sockaddr in let assigned_port = match assigned_port with | Some x -> x | None -> assert false in (server_thread, (Unix.string_of_inet_addr ipv6), assigned_port) (* Dual stack inet4 and inet6: *) let inet_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port server_fun = let (thrd4, addr4, port4) as r4 = inet4_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port server_fun in let () = Log.printf1 "dual stack server: inet4 thread started (%d)\n" (Thread.id thrd4) in let return_raising e = Log.print_exn ~prefix:"dual stack server: I cannot start both servers because of: " e; (* Try to kill thrd4 after having waited 1 second (thrd4 shoud have the time tu register its killing thunk), but do this in another thread, in order to return immediately: *) ThreadExtra.delayed_kill 1. thrd4; raise e in let (thrd6, addr6, port6) as r6 = try inet6_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range6 ?ipv6 ~port:port4 server_fun with | Binding e when port=None -> (try inet6_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port server_fun with e -> return_raising e) | e -> return_raising e in Log.printf1 "dual stack server: inet6 thread started (%d)\n" (Thread.id thrd6); (r4,r6) (* fix Unix.SO_RCVBUF if needed *) let fix_SO_RCVBUF_if_needed ~max_input_size fd = let recv_buffer_size = Unix.getsockopt_int fd Unix.SO_RCVBUF in (if max_input_size > recv_buffer_size then Log.printf1 "Fixing option Unix.SO_RCVBUF to the value %d\n" max_input_size; Unix.setsockopt_int fd Unix.SO_RCVBUF max_input_size); () class common_low_level_methods_on_socket fd = object method get_send_buffer_size = Unix.getsockopt_int fd Unix.SO_SNDBUF method set_send_buffer_size x = Unix.setsockopt_int fd Unix.SO_SNDBUF x method get_recv_buffer_size = Unix.getsockopt_int fd Unix.SO_RCVBUF method set_recv_buffer_size x = Unix.setsockopt_int fd Unix.SO_RCVBUF x method get_close_linger = Unix.getsockopt_optint fd Unix.SO_LINGER method set_close_linger x = Unix.setsockopt_optint fd Unix.SO_LINGER x end (* High-level representation of the structure available, after a connection, to both endpoints. The max_input_size is set by default to 1514 (Ethernet: 1514=1526-12 (8 preamble and 4 CRC)) *) class stream_or_seqpacket_bidirectional_channel ?(max_input_size=1514) ?seqpacket fd = let () = fix_SO_RCVBUF_if_needed ~max_input_size fd in object inherit common_low_level_methods_on_socket fd val input_buffer = Bytes.create max_input_size val max_input_size = max_input_size method shutdown ?receive ?send () = try let shutdown_command = match receive, send with | None, None | Some (), None -> Unix.SHUTDOWN_RECEIVE | None, Some () -> Unix.SHUTDOWN_SEND | Some (), Some () -> Unix.SHUTDOWN_ALL in Unix.shutdown fd shutdown_command with e -> Log.print_exn ~prefix:"channel#shutdown: " e; raise (Closing e) method sockaddr0 = Unix.getsockname fd method sockaddr1 = Unix.getpeername fd end (* class stream_or_seqpacket_bidirectional_channel *) class stream_channel ?max_input_size fd = let in_channel = Unix.in_channel_of_descr fd in let out_channel = Unix.out_channel_of_descr fd in let raise_but_also_log_it ?sending caller e = let prefix = Printf.sprintf "stream_channel#%s: " caller in let () = Log.print_exn ~prefix e in if sending=None then raise (Receiving e) else raise (Sending e) in let tutor0 f x caller = try f x with e -> raise_but_also_log_it caller e in let tutor1 f x y caller = try f x y; flush x with e -> raise_but_also_log_it ~sending:() caller e in let return_of_at_least at_least = match at_least with | None -> fun y -> y | Some m -> let previous = Unix.getsockopt_int fd Unix.SO_RCVLOWAT in let () = Unix.setsockopt_int fd Unix.SO_RCVLOWAT m in fun y -> (* restore the previous value and return: *) let () = Unix.setsockopt_int fd Unix.SO_RCVLOWAT previous in y in object inherit stream_or_seqpacket_bidirectional_channel ?max_input_size fd as super method receive ?at_least () : string = let return = return_of_at_least at_least in try let n = Unix.recv fd input_buffer 0 max_input_size [] in (if n=0 then failwith "received 0 bytes (peer terminated?)"); return (String.sub input_buffer 0 n) with e -> Log.print_exn ~prefix:"stream_channel#receive: " e; let _ = return "" in raise (Receiving e) method peek ?(at_least=0) () : string option = try Unix.set_nonblock fd; let n = Unix.recv fd input_buffer 0 max_input_size [Unix.MSG_PEEK] in Unix.clear_nonblock fd; if n>=at_least then Some (String.sub input_buffer 0 n) else let () = if at_least>0 then Log.printf2 "stream_channel#peek: received %d bytes (expected at least %d)\n" n at_least in None with e -> Unix.clear_nonblock fd; Log.print_exn ~prefix:"stream_channel#peek: result is None because of exception: " e; None method send (x:string) : unit = let rec send_stream_loop x off len = if len=0 then () else let n = Unix.send fd x off len [] in if n = 0 then failwith "failed to send in a stream channel: no more than 0 bytes sent!" else if n Log.print_exn ~prefix:"stream_channel#send: " e; raise (Sending e) method input_char () : char = tutor0 Pervasives.input_char in_channel "input_char" method input_line () : string = tutor0 Pervasives.input_line in_channel "input_line" method input_byte () : int = tutor0 Pervasives.input_byte in_channel "input_byte" method input_binary_int () : int = tutor0 Pervasives.input_binary_int in_channel "input_binary_int" method input_value : 'a. unit -> 'a = fun () -> tutor0 Pervasives.input_value in_channel "input_value" method output_char x = tutor1 Pervasives.output_char out_channel x "output_char" method output_line x = tutor1 Pervasives.output_string out_channel (x^"\n") "output_line" method output_byte x = tutor1 Pervasives.output_byte out_channel x "output_byte" method output_binary_int x = tutor1 Pervasives.output_binary_int out_channel x "output_binary_int" method output_value : 'a. 'a -> unit = fun x -> tutor1 Pervasives.output_value out_channel x "output_value" method get_send_wait_at_least = Unix.getsockopt_int fd Unix.SO_SNDLOWAT method set_send_wait_at_least x = Unix.setsockopt_int fd Unix.SO_SNDLOWAT x method get_recv_wait_at_least = Unix.getsockopt_int fd Unix.SO_RCVLOWAT method set_recv_wait_at_least x = Unix.setsockopt_int fd Unix.SO_RCVLOWAT x end (* class stream_channel *) (** Useful for writing polymorphic protocols that refer only to method #send and #receive:. Note that the parameter `max_input_size' became meaningless because the method #receive is defined as ch#input_line that ignores this parameter. *) let line_oriented_channel_of_stream_channel (ch:stream_channel) = object method receive = ch#input_line method send = ch#output_line method peek () = match ch#peek ~at_least:1 () with | None -> None | Some s -> (try let i = String.index s '\n' in Some (String.sub s 0 i) (* do not include "\n" *) with Not_found -> None) end class seqpacket_channel ?max_input_size fd = object inherit stream_or_seqpacket_bidirectional_channel ?max_input_size ~seqpacket:() fd method receive () : string = try let n = Unix.recv fd input_buffer 0 max_input_size [] in (if n=0 then failwith "received 0 bytes (peer terminated?)"); String.sub input_buffer 0 n with e -> Log.print_exn ~prefix:"seqpacket_channel#receive: " e; raise (Receiving e) method peek () : string option = try Unix.set_nonblock fd; let n = Unix.recv fd input_buffer 0 max_input_size [Unix.MSG_PEEK] in Unix.clear_nonblock fd; if n>0 then Some (String.sub input_buffer 0 n) else None with e -> Unix.clear_nonblock fd; Log.print_exn ~prefix:"seqpacket_channel#peek: result is None because of exception: " e; None method send (x:string) : unit = try let len = String.length x in let n = Unix.send fd x 0 len [] in if n Log.print_exn ~prefix:"seqpacket_channel#send: " e; raise (Sending e) end (* class seqpacket_channel *) exception Unexpected_sender of string (* Typically the client builds its socketfile (0), send it to the server through the stream channel, then receives its socketfile for output (1). *) class dgram_channel ?(max_input_size=1514) ~fd0 ~sockaddr1 () = let () = fix_SO_RCVBUF_if_needed ~max_input_size fd0 in let input_buffer = Bytes.create max_input_size in let sockaddr0 = Unix.getsockname fd0 in object (self) inherit common_low_level_methods_on_socket fd0 method receive () : string = try let (n, sockaddr) = Unix.recvfrom fd0 input_buffer 0 max_input_size [] in (if sockaddr <> sockaddr1 then raise (Unexpected_sender (string_of_sockaddr sockaddr))); String.sub input_buffer 0 n with e -> Log.print_exn ~prefix:"dgram_channel#receive: " e; raise (Receiving e) method peek () : string option = try Unix.set_nonblock fd0; let (n, sockaddr) = Unix.recvfrom fd0 input_buffer 0 max_input_size [Unix.MSG_PEEK] in Unix.clear_nonblock fd0; (if sockaddr <> sockaddr1 then raise (Unexpected_sender (string_of_sockaddr sockaddr))); if n>0 then Some (String.sub input_buffer 0 n) else None with e -> Unix.clear_nonblock fd0; Log.print_exn ~prefix:"dgram_channel#peek: result is None because of exception: " e; None method send (x:string) : unit = try let len = String.length x in (* fd0 represents where I want to receive the answer: *) let n = Unix.sendto fd0 x 0 len [] sockaddr1 in if n Log.print_exn ~prefix:"dgram_channel#send: " e; raise (Sending e) method shutdown ?receive ?send () = try let shutdown_command = match receive, send with | None, None | Some (), None -> Unix.SHUTDOWN_RECEIVE | None, Some () -> Unix.SHUTDOWN_SEND | Some (), Some () -> Unix.SHUTDOWN_ALL in (match shutdown_command with | Unix.SHUTDOWN_RECEIVE | Unix.SHUTDOWN_ALL -> (try Unix.close fd0 with _ -> ()); (try Unix.unlink (socketfile_of_sockaddr sockaddr0) with _ -> ()); | _ -> () ); (match shutdown_command with | Unix.SHUTDOWN_SEND | Unix.SHUTDOWN_ALL -> (try Unix.unlink (socketfile_of_sockaddr sockaddr1) with _ -> ()); | _ -> () ) with e -> Log.print_exn ~prefix:"dgram_channel#shutdown: " e; raise (Closing e) method sockaddr0 = sockaddr0 method sockaddr1 = sockaddr1 method chmod_sockaddr0 x = match sockaddr0 with | Unix.ADDR_UNIX socketfile -> Unix.chmod socketfile x | _ -> () initializer self#chmod_sockaddr0 0o777 end (* class dgram_channel *) let dgram_input_socketfile_of ?dgram_output_socketfile ~stream_socketfile () = let make_socket ~bind_to = let result = Unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0 in let socketfile = bind_to in bind result (Unix.ADDR_UNIX socketfile); Log.printf1 "Unix datagram socket bound to %s\n" socketfile; result in let socketfile1 = dgram_output_socketfile in let socketfile0 = let temp_dir = Filename.dirname stream_socketfile in (* Example: 14219.0<===8173az2 *) let prefix = Printf.sprintf "%d.%d<===" (Unix.getpid ()) (Thread.id (Thread.self ())) in let create_name_from_socketfile () = (* Filename.temp_file add an hexadecimal string after the prefix: *) let result = Filename.temp_file ~temp_dir prefix "" in let () = Unix.unlink result in result in let make_the_symlink ~link_suffix ~target = let link_prefix = Printf.sprintf "%d.%d>===" (Unix.getpid ()) (Thread.id (Thread.self ())) in let link_name = Printf.sprintf "%s/%s%s" temp_dir link_prefix link_suffix in Unix.symlink target link_name; ThreadExtra.at_exit (fun () -> Unix.unlink link_name) in let try_to_create_name_from_socketfile1_generated_by_this_library () = let socketfile1 = Option.extract socketfile1 in (assert (temp_dir = Filename.dirname socketfile1)); let basename1 = Filename.basename socketfile1 in let (process, thread, channel_tag) = Scanf.sscanf basename1 "%d.%d<===%s" (fun p t s -> (p,t,s)) in (* Example: 14219.0<===8173az2===<14220.1 *) let candidate = Printf.sprintf "%s/%s%s===<%d.%d" temp_dir prefix channel_tag process thread in (assert (not (Sys.file_exists candidate))); let () = (* Make a symlink useful to understand what's happening: Example: 14219.0>===8173az2===>14220.1 *) make_the_symlink ~link_suffix:(Printf.sprintf "%s===>%d.%d" channel_tag process thread) ~target:basename1 in candidate in let try_to_create_name_from_exogenous_socketfile1 () = let socketfile1 = Option.extract socketfile1 in (assert (temp_dir = Filename.dirname socketfile1)); let basename1 = Filename.basename socketfile1 in (* Example: 14219.0<===foo *) let candidate = Printf.sprintf "%s/%s%s" temp_dir prefix basename1 in (assert (not (Sys.file_exists candidate))); let () = (* Make a symlink useful to understand what's happening: Example: 14219.0>===foo *) make_the_symlink ~link_suffix:basename1 ~target:basename1 in candidate in (try try_to_create_name_from_socketfile1_generated_by_this_library () with _ -> try try_to_create_name_from_exogenous_socketfile1 () with _ -> create_name_from_socketfile () ) (* end of socketfile0 definition *) in let sockaddr0 = Unix.ADDR_UNIX socketfile0 in let fd0 = make_socket ~bind_to:socketfile0 in (fd0, sockaddr0, socketfile0) ;; let dgram_input_port_of ?dgram_output_port ~my_stream_inet_addr () = let domain = domain_of_inet_addr my_stream_inet_addr in let fd0 = Unix.socket domain Unix.SOCK_DGRAM 0 in let (sockaddr0, dgram_input_port) = let () = match dgram_output_port with | None -> bind fd0 (Unix.ADDR_INET (my_stream_inet_addr, 0)) | Some p -> (* Try to reserve the same port of the client: *) try Unix.bind fd0 (Unix.ADDR_INET (my_stream_inet_addr, p)); with e -> (* Note here that the exception is Unix.Unix_error(50, "bind", "") but for a very strange OCaml (toplevel 3.11.2) behaviour (bug?) the pattern Unix.Unix_error (_, _, _) doesn't catch the exception!!! *) bind fd0 (Unix.ADDR_INET (my_stream_inet_addr, 0)); in match Unix.getsockname fd0 with | (Unix.ADDR_INET (_, assigned_port)) as sockaddr0 -> (sockaddr0, assigned_port) | _ -> assert false in (fd0, sockaddr0, dgram_input_port) ;; type socketfile = string type 'a stream_protocol = stream_channel -> 'a type 'a seqpacket_protocol = seqpacket_channel -> 'a type 'a dgram_protocol = (stream_channel -> dgram_channel) * (dgram_channel -> 'a) let call_logging_exception ?prefix protocol channel = try Either.Right (protocol channel) with e -> ((Log.print_exn ?prefix e); Either.Left e) let server_fun_of_stream_protocol ?max_input_size (protocol:'a stream_protocol) = function fd -> let channel = new stream_channel ?max_input_size fd in let result = call_logging_exception ~prefix:"stream server exception: " protocol channel in (try channel#shutdown ~receive:() () with _ -> ()); result let server_fun_of_seqpacket_protocol ?max_input_size (protocol:'a seqpacket_protocol) = function fd -> let channel = new seqpacket_channel ?max_input_size fd in let result = call_logging_exception ~prefix:"seqpacket server exception: " protocol channel in (try channel#shutdown ~receive:() () with _ -> ()); result (* seqpacket - unix *) let seqpacket_unix_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?socketfile ~(protocol:seqpacket_channel -> unit) () = let server_fun = server_fun_of_seqpacket_protocol ?max_input_size protocol in unix_server ?max_pending_requests ~seqpacket:() ?tutor_behaviour ?no_fork ?socketfile server_fun (* stream - unix *) let stream_unix_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?socketfile ~(protocol:stream_channel -> unit) () = let server_fun = server_fun_of_stream_protocol ?max_input_size protocol in unix_server ?max_pending_requests ?tutor_behaviour ?no_fork ?socketfile server_fun (* stream - inet4 *) let stream_inet4_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port ~(protocol:stream_channel -> unit) () = let server_fun = server_fun_of_stream_protocol ?max_input_size protocol in inet4_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port server_fun (* stream - inet6 *) let stream_inet6_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port ~(protocol:stream_channel -> unit) () = let server_fun = server_fun_of_stream_protocol ?max_input_size protocol in inet6_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port server_fun (* stream - inet (both 4 and 6) trying to reserve for ipv6 the same port reserved for ipv4: *) let stream_inet_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port ~(protocol:stream_channel -> unit) () = let server_fun = server_fun_of_stream_protocol ?max_input_size protocol in inet_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port server_fun let stream_dgram_protocol_composition ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> 'a) = fun stream_channel -> begin let dgram_channel = bootstrap stream_channel in (try stream_channel#shutdown ~receive:() () with _ -> ()); let result = (protocol dgram_channel) in (dgram_channel#shutdown ~receive:() ()); result end (* datagram - unix *) let dgram_unix_server ?max_pending_requests ?stream_max_input_size ?tutor_behaviour ?no_fork ?socketfile ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> unit) () = let protocol_composition = stream_dgram_protocol_composition ~bootstrap ~protocol in let server_fun = server_fun_of_stream_protocol ?max_input_size:stream_max_input_size protocol_composition in unix_server ?max_pending_requests ?tutor_behaviour ?no_fork ?socketfile server_fun (* datagram - inet4 *) let dgram_inet4_server ?max_pending_requests ?stream_max_input_size ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> unit) () = let protocol_composition = stream_dgram_protocol_composition ~bootstrap ~protocol in let server_fun = server_fun_of_stream_protocol ?max_input_size:stream_max_input_size protocol_composition in inet4_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port server_fun (* datagram - inet6 *) let dgram_inet6_server ?max_pending_requests ?stream_max_input_size ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> unit) () = let protocol_composition = stream_dgram_protocol_composition ~bootstrap ~protocol in let server_fun = server_fun_of_stream_protocol ?max_input_size:stream_max_input_size protocol_composition in inet6_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port server_fun (* datagram - inet *) let dgram_inet_server ?max_pending_requests ?stream_max_input_size ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> unit) () = let protocol_composition = stream_dgram_protocol_composition ~bootstrap ~protocol in let server_fun = server_fun_of_stream_protocol ?max_input_size:stream_max_input_size protocol_composition in inet_server ?max_pending_requests ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port server_fun let client ?seqpacket client_fun sockaddr = let socket_type = match seqpacket with | None -> Unix.SOCK_STREAM | Some () -> Unix.SOCK_SEQPACKET (* implies domain = Unix.ADDR_UNIX *) in let socket = Either.apply_or_catch (Unix.socket (Unix.domain_of_sockaddr sockaddr) socket_type) 0 in Either.bind socket (fun socket -> try Unix.connect socket sockaddr; (try Unix.set_close_on_exec socket with Invalid_argument _ -> ()); client_fun socket with e -> begin Unix.close socket; Either.Left (Connecting e) end) let unix_client ?seqpacket ~socketfile client_fun = let sockaddr = Unix.ADDR_UNIX socketfile in client ?seqpacket client_fun sockaddr let inet_client ~ipv4_or_v6 ~port client_fun = try let ipv4_or_v6 = Unix.inet_addr_of_string ipv4_or_v6 in let sockaddr = Unix.ADDR_INET (ipv4_or_v6, port) in client client_fun sockaddr with e -> Either.Left e (* stream - unix *) let stream_unix_client ?max_input_size ~socketfile ~(protocol:stream_channel -> 'a) () = let client_fun = server_fun_of_stream_protocol ?max_input_size protocol in unix_client ~socketfile client_fun (* seqpacket - unix *) let seqpacket_unix_client ?max_input_size ~socketfile ~(protocol:'a seqpacket_protocol) () = let client_fun = server_fun_of_seqpacket_protocol ?max_input_size protocol in unix_client ~seqpacket:() ~socketfile client_fun (* stream - inet (v4 or v6) *) let stream_inet_client ?max_input_size ~ipv4_or_v6 ~port ~(protocol:stream_channel -> 'a) () = let client_fun = server_fun_of_stream_protocol ?max_input_size protocol in inet_client ~ipv4_or_v6 ~port client_fun (* datagram - unix *) let dgram_unix_client ?stream_max_input_size ~socketfile ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> 'a) () = let protocol_composition = stream_dgram_protocol_composition ~bootstrap ~protocol in let client_fun = server_fun_of_stream_protocol ?max_input_size:stream_max_input_size protocol_composition in unix_client ~socketfile client_fun (* datagram - inet4 or inet6 *) let dgram_inet_client ?stream_max_input_size ~ipv4_or_v6 ~port ~(bootstrap : stream_channel -> dgram_channel) ~(protocol : dgram_channel -> 'a) () = let protocol_composition = stream_dgram_protocol_composition ~bootstrap ~protocol in let client_fun = server_fun_of_stream_protocol ?max_input_size:stream_max_input_size protocol_composition in inet_client ~ipv4_or_v6 ~port client_fun module Socat = struct (* The following code is a macro, not a function, in order to bypass the type-system. Actually, the type-system doesn't understand the compatibility among a function and actuals that are objects of different types. In our case, channel objects may have the #receive method slightly different, but all of these methods can be called in a default way, just giving them the argument (). The following code should generate only this constraint, even if it would not so easy to express. On the contrary, the generated constraint is that the function will accept only actuals of type < receive : unit -> string; send : string -> unit; .. >. We bypass this problem using a macro: *) DEFINE MACRO_CROSSOVER_LINK (chA,chB) = let rec loop_A_to_B () = try let x = (try chA#receive () with e -> chB#shutdown ~send:() (); raise e) in let () = (try chB#send x with e -> chA#shutdown ~receive:() (); raise e) in loop_A_to_B () with _ -> () in let rec loop_B_to_A () = try let x = (try chB#receive () with e -> chA#shutdown ~send:() (); raise e) in let () = (try chA#send x with e -> chB#shutdown ~receive:() (); raise e) in loop_B_to_A () with _ -> () in let thread_A_to_B = Thread.create loop_A_to_B () in let thread_B_to_A = Thread.create loop_B_to_A () in Thread.join thread_A_to_B; Thread.join thread_B_to_A; () (* -------------------------------- * of_unix_stream_server * -------------------------------- *) (** Example: {[# Sys.command "xterm" ;; : int = 0 # Sys.command "DISPLAY=127.0.0.1:42 xterm" ;; xterm Xt error: Can't open display: 127.0.0.1:42 : int = 1 # Network.Socat.inet4_of_unix_stream_server ~port:6042 ~socketfile:"/tmp/.X11-unix/X0" () ;; : Thread.t * string * int = (, "0.0.0.0", 6042) # Sys.command "DISPLAY=127.0.0.1:42 xterm" ;; : int = 0 ]} *) let inet4_of_unix_stream_server (* inet4 server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port (* unix client parameters and inet4 server result: *) ~socketfile () : Thread.t * string * int = stream_inet4_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_unix_client ?max_input_size ~socketfile ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () let inet6_of_unix_stream_server (* inet6 server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port (* unix client parameters and inet6 server result: *) ~socketfile () : Thread.t * string * int = stream_inet6_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_unix_client ?max_input_size ~socketfile ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () let inet_of_unix_stream_server (* inet6 server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port (* unix client parameters and inet6 server result: *) ~socketfile () : (Thread.t * string * int) * (Thread.t * string * int) = stream_inet_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_unix_client ?max_input_size ~socketfile ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () let unix_of_unix_stream_server (* unix server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?socketfile (* unix client parameters and unix server result: *) ~dsocketfile () : Thread.t * string = stream_unix_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?socketfile ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_unix_client ?max_input_size ~socketfile:dsocketfile ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () (* -------------------------------- * of_inet_stream_server * -------------------------------- *) let unix_of_inet_stream_server (* unix server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?socketfile (* inet client parameters and unix server result: *) ~ipv4_or_v6 ~port () : Thread.t * string = stream_unix_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?socketfile ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_inet_client ?max_input_size ~ipv4_or_v6 ~port ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () let inet4_of_inet_stream_server (* inet4 server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port (* inet client parameters and inet4 server result: *) ~ipv4_or_v6 ~dport () : Thread.t * string * int = stream_inet4_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?ipv4 ?port ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_inet_client ?max_input_size ~ipv4_or_v6 ~port:dport ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () let inet6_of_inet_stream_server (* inet4 server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port (* inet client parameters and inet4 server result: *) ~ipv4_or_v6 ~dport () : Thread.t * string * int = stream_inet6_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range6 ?ipv6 ?port ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_inet_client ?max_input_size ~ipv4_or_v6 ~port:dport ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () let inet_of_inet_stream_server (* inet4 server parameters: *) ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port (* inet client parameters and inet4 server result: *) ~ipv4_or_v6 ~dport () : (Thread.t * string * int) * (Thread.t * string * int) = stream_inet_server ?max_pending_requests ?max_input_size ?tutor_behaviour ?no_fork ?range4 ?range6 ?ipv4 ?ipv6 ?port ~protocol:begin fun (chA:stream_channel) -> (* When a connection is accepted the server became a client of the remote unix server: *) ignore (stream_inet_client ?max_input_size ~ipv4_or_v6 ~port:dport ~protocol:begin fun (chB:stream_channel) -> MACRO_CROSSOVER_LINK (chA,chB) end (* client protocol *) ()) end (* server protocol *) () end (* module Socat *) IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Examples = struct let server_max_input_size = 10;; let max_input_size = server_max_input_size ;; (* A simple echo server: *) let rec simple_echo_server_protocol ch = let pr = Printf.kfprintf flush stderr in let x = ch#receive () in let () = ch#send x in if x="quit" then (pr "ECHO server: exiting.\n") else simple_echo_server_protocol ch (* A simple echo client: *) let rec simple_echo_client_protocol ch = let pr = Printf.kfprintf flush stderr in let pr1 = Printf.kfprintf flush stderr in let pr2 = Printf.kfprintf flush stderr in pr "Enter the text to send: "; let x = try input_line stdin with _ -> "quit" in let () = (ch#send x) in let y = ch#receive () in let n = String.length y in (if x=y then (pr1 "Echo received, ok. (%d chars)\n" n) else (pr2 "Bad echo!!!!! Received: %s (%d chars)\n" y n) ); if y="quit" then (pr "ECHO client: exiting.\n") else simple_echo_client_protocol ch (* For both inet4 and inet6: *) let dgram_inet_echo_server ?no_fork ?inet6 ?port () = let (thread, ip, port) = let bootstrap (ch:stream_channel) = (* The client provides the port where it will receive datagrams: *) let peer = string_of_sockaddr ch#sockaddr1 in Log.printf1 "Receiving the dgram-inet port number (my output line) from %s\n" peer; let dgram_output_port = ch#input_binary_int () in let peer_inet_addr = fst (inet_addr_and_port_of_sockaddr ch#sockaddr1) in Log.printf2 "Ok, my output line is %s:%d\n" (Unix.string_of_inet_addr peer_inet_addr) dgram_output_port; let sockaddr1 = Unix.ADDR_INET (peer_inet_addr, dgram_output_port) in let my_stream_inet_addr = fst (inet_addr_and_port_of_sockaddr ch#sockaddr0) in let (fd0, sockaddr0, port0) = dgram_input_port_of ~dgram_output_port ~my_stream_inet_addr () in let dgram_channel = new dgram_channel ~max_input_size ~fd0 ~sockaddr1 () in Log.printf2 "Sending the dgram-inet port number %d (my input line) to %s\n" port0 peer; (ch#output_binary_int port0); dgram_channel in let protocol (ch:dgram_channel) = simple_echo_server_protocol ch in match inet6 with | None -> dgram_inet4_server ?no_fork ?port ~bootstrap ~protocol () | Some () -> dgram_inet6_server ?no_fork ?port ~bootstrap ~protocol () in (thread, ip, port) let dgram_unix_echo_server ?no_fork ?stream_socketfile () = let stream_socketfile = match stream_socketfile with | Some x -> x | None -> socketname_in_a_fresh_made_directory "ctrl" in let (t, socketfile) = let bootstrap (ch:stream_channel) = let sockname = string_of_sockaddr ch#sockaddr0 in Log.printf1 "Receiving the filename (my output line) from %s\n" sockname; let dgram_output_socketfile = ch#receive () in Log.printf1 "Ok, my output line is %s\n" dgram_output_socketfile; let (fd0, sockaddr0, socketfile0) = dgram_input_socketfile_of ~dgram_output_socketfile ~stream_socketfile () in let sockaddr1 = Unix.ADDR_UNIX dgram_output_socketfile in let dgram_channel = new dgram_channel ~max_input_size ~fd0 ~sockaddr1 () in Log.printf2 "Sending the filename %s (my input line) to %s\n" socketfile0 sockname; (ch#send socketfile0); dgram_channel in let protocol (ch:dgram_channel) = simple_echo_server_protocol ch in dgram_unix_server ?no_fork ~bootstrap ~protocol ~socketfile:stream_socketfile () in (t, socketfile) let dgram_inet_echo_client ~ipv4_or_v6 ~port () = let bootstrap (stream_channel as ch) = let my_stream_inet_addr = fst (inet_addr_and_port_of_sockaddr ch#sockaddr0) in let (fd0, sockaddr0, port0) = dgram_input_port_of ~my_stream_inet_addr () in let peer = string_of_sockaddr ch#sockaddr1 in Log.printf2 "Sending the dgram-inet port number %d (my input line) to %s\n" port0 peer; (ch#output_binary_int port0); Log.printf1 "Receiving the dgram-inet port number (my output line) from %s\n" peer; let dgram_output_port = ch#input_binary_int () in let peer_inet_addr = fst (inet_addr_and_port_of_sockaddr ch#sockaddr1) in Log.printf2 "Ok, my output line is %s:%d\n" (Unix.string_of_inet_addr peer_inet_addr) dgram_output_port; let sockaddr1 = Unix.ADDR_INET (peer_inet_addr, dgram_output_port) in new dgram_channel ~fd0 ~sockaddr1 () in let protocol ch = simple_echo_client_protocol ch in dgram_inet_client ~bootstrap ~protocol ~ipv4_or_v6 ~port () let dgram_unix_echo_client ~stream_socketfile () = let bootstrap (ch:stream_channel) = let (fd0, sockaddr0, socketfile0) = dgram_input_socketfile_of ~stream_socketfile () in (ch#send socketfile0); let socketfile1 = ch#receive () in let sockaddr1 = Unix.ADDR_UNIX socketfile1 in new dgram_channel ~fd0 ~sockaddr1 () in let protocol (ch:dgram_channel) = simple_echo_client_protocol ch in dgram_unix_client ~bootstrap ~protocol ~socketfile:stream_socketfile () let stream_unix_echo_server ?no_fork ?socketfile () = let socketfile = match socketfile with | Some x -> x | None -> fresh_socketname () in let (t, socketfile) = let protocol (ch:stream_channel) = simple_echo_server_protocol (line_oriented_channel_of_stream_channel ch) in stream_unix_server ?no_fork ~max_input_size ~protocol ~socketfile () in (t, socketfile) let stream_unix_echo_client ~socketfile () = let protocol (ch:stream_channel) = simple_echo_client_protocol (line_oriented_channel_of_stream_channel ch) in stream_unix_client ~protocol ~socketfile () let seqpacket_unix_echo_server ?no_fork ?socketfile () = let socketfile = match socketfile with | Some x -> x | None -> fresh_socketname () in let (t, socketfile) = let protocol (ch:seqpacket_channel) = simple_echo_server_protocol ch in seqpacket_unix_server ~max_input_size ?no_fork ~protocol ~socketfile () in (t, socketfile) let seqpacket_unix_echo_client ~socketfile () = let protocol (ch:seqpacket_channel) = simple_echo_client_protocol ch in seqpacket_unix_client ~protocol ~socketfile () (* For both inet4 and inet6: *) let stream_inet_echo_server ?no_fork ?inet6 ?port () = let (thread, ip, port) = let protocol (ch:stream_channel) = simple_echo_server_protocol (line_oriented_channel_of_stream_channel ch) in match inet6 with | None -> stream_inet4_server ?no_fork ?port ~max_input_size ~protocol () | Some () -> stream_inet6_server ?no_fork ?port ~max_input_size ~protocol () in (thread, ip, port) let stream_inet_echo_client ~ipv4_or_v6 ~port () = let protocol ch = simple_echo_client_protocol (line_oriented_channel_of_stream_channel ch) in stream_inet_client ~protocol ~ipv4_or_v6 ~port () end (* module Examples *) ENDIF ocamlbricks-0.90+bzr456.orig/STRUCTURES/future.mli0000644000175000017500000000313313175721005020463 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Synchronization structure for functional/concurrent (threads) programming model. This structure allows an asynchronous kind of function application. Differently from the default [Thread], the result of the application is not lost but accessible with the primitives [touch] and [taste]. The same holds for exceptions and their associated values: if an exception interrupts the computation, it will be re-raised in any thread touching or tasting the future. This behaviour makes the primitive [future] preferrable with respect to the standard [Thread.create] {e even} for threads providing a non interesting result, i.e. a result of type [unit]. *) type 'a future type 'a t = 'a future val future : ('a -> 'b) -> 'a -> 'b future (** {2 Result} *) val touch : 'a future -> 'a val taste : 'a future -> 'a option val thread_of : 'a future -> Thread.t ocamlbricks-0.90+bzr456.orig/STRUCTURES/stateful_modules.ml0000644000175000017500000000672113175721005022365 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Modules encapsulating a global state possibly shared by threads. *) module type Type = sig type t val name:string option end module Variable (Type:Type) = struct let failmsg = match Type.name with | None -> Printf.sprintf "Stateful_modules: undefined content" | Some x -> Printf.sprintf "Stateful_modules: %s is undefined" x type t = Type.t let content = ref None let set (x:t) = (content := Some (lazy x)) let unset () = (content := None) let get () = match !content with | Some x -> Some (Lazy.force x) | None -> None let extract () = match !content with | Some x -> Lazy.force x | None -> failwith failmsg let lazy_set lx = (content := Some lx) end module Thread_shared_variable (Type:Type) = struct include Variable (Type) module Mutex = MutexExtra.Recursive let mutex = Mutex.create () (* we provide these new methods: *) let apply_with_mutex f x = Mutex.apply_with_mutex mutex f x let lock () = Mutex.lock mutex let unlock () = Mutex.unlock mutex (* and the thread-safe versions of accessors: *) let set x = apply_with_mutex set x let unset () = apply_with_mutex unset () let get x = apply_with_mutex get x let extract x = apply_with_mutex extract x let lazy_set x = apply_with_mutex lazy_set x end module type Type_with_init = sig type t val name : string option val init : unit -> t end (** The idea is basically that when a process forks, its child must reset the structure. There isn't sharing among processes, but only among threads of the same process. *) module Process_private_thread_shared_variable (Type:Type_with_init) = struct include Variable (Type) module Mutex = MutexExtra.Recursive let mutex = Mutex.create () (* we provide these new methods: *) let apply_with_mutex f x = Mutex.apply_with_mutex mutex f x let lock () = Mutex.lock mutex let unlock () = Mutex.unlock mutex (* First redefiniton: the process-safe versions of accessors: *) let owner = ref (Unix.getpid ()) (* Initialized at the module creation time *) let get () = let pid = Unix.getpid () in if pid = !owner then get () else begin set (Type.init ()); owner := pid; get () end let extract () = let pid = Unix.getpid () in if pid = !owner then extract () else begin set (Type.init ()); owner := pid; extract () end (* Second redefiniton: the thread-safe versions of accessors: *) let set x = apply_with_mutex set x let unset () = apply_with_mutex unset () let get x = apply_with_mutex get x let extract x = apply_with_mutex extract x let lazy_set x = apply_with_mutex lazy_set x (* The variable is automatically initialized in a lazy way by the provided init() function: *) let () = lazy_set (lazy (Type.init ())) end ocamlbricks-0.90+bzr456.orig/STRUCTURES/lazy_perishable.mli0000644000175000017500000000216013175721005022325 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2015 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** Lazy values with a lifetime. When the delay is expired, the value is recalculated. *) type 'a t type lifetime = seconds and seconds = float val create : 'a Thunk.t -> lifetime -> 'a t val force : 'a t -> 'a (* The value will be recalculated when `force' will be called the next time: *) val set_expired : 'a t -> unit ocamlbricks-0.90+bzr456.orig/COPYING0000644000175000017500000004311013175721005015755 0ustar lucaslucas GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. ocamlbricks-0.90+bzr456.orig/Makefile.local0000644000175000017500000001543513175721005017464 0ustar lucaslucas# This -*- makefile -*- is part of our reusable OCaml BRICKS library # Copyright (C) 2008, 2011 Luca Saiu # Copyright (C) 2008, 2010, 2011 Jean-Vincent Loddo # Copyright (C) 2008, 2010, 2011 Université Paris 13 # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # Set this variable to "-verbose 0" for more details OCAMLBUILD_OPTIONS=-quiet # BYTE_COMPILE_OPTIONS += -custom -ccopt -L./ -cclib -L./ COMPILE_OPTIONS += -g -thread DIRECTORIES_TO_INCLUDE = threads lablgtk2 camlp4 LIBRARIES_TO_LINK = str unix threads lablgtk NATIVE_PROGRAMS += mutexExtra_test.native BYTE_PROGRAMS += mutexExtra_test.byte NATIVE_LIBRARY_NAME = ocamlbricks.cmxa BYTE_LIBRARY_NAME = ocamlbricks.cma NATIVE_LIBRARIES = $(shell \ if which ocamlopt.opt &>/dev/null || which ocamlopt &>/dev/null;\ then echo $(NATIVE_LIBRARY_NAME); fi) BYTE_LIBRARIES = $(shell \ if which ocamlc.opt &>/dev/null || which ocamlc &>/dev/null;\ then echo $(BYTE_LIBRARY_NAME); fi) # Empty for OCaml 3.x.y series, set to "-DOCAML4_OR_LATER" for 4.x.y or later: OCAML4_OR_LATER=$(shell if grep -q "^[4-9]" <<<"$(OCAML_VERSION)"; then echo "-DOCAML4_OR_LATER"; fi) # Empty for OCaml 3.x.y series, set to "-DOCAML4_02_OR_LATER" for 4.02.y or later: OCAML4_02_OR_LATER=$(shell if grep -q "^\([5-9]\)\|\(4[.]\([1-9]\|0[2-9]\)\)" <<<"$(OCAML_VERSION)"; then echo "-DOCAML4_02_OR_LATER"; fi) # Empty for OCaml 3.x.y series, set to "-DOCAML4_04_OR_LATER" for 4.04.y or later: OCAML4_04_OR_LATER=$(shell if grep -q "^\([5-9]\)\|\(4[.]\([1-9]\|0[4-9]\)\)" <<<"$(OCAML_VERSION)"; then echo "-DOCAML4_04_OR_LATER"; fi) # Transmit the information about the compiler version in order to # activate conditional compilation: PP_OPTION = camlp4of $(OCAML4_OR_LATER) $(OCAML4_02_OR_LATER) $(OCAML4_04_OR_LATER) GETTEXT=GETTEXT C_OBJECTS_TO_LINK = gettext-c-wrapper does-process-exist-c-wrapper waitpid-c-wrapper OTHER_LIBRARY_FILES_TO_INSTALL = _build/{gettext-c-wrapper.o,does-process-exist-c-wrapper.o,gettext_extract_pot_p4.cmo,waitpid-c-wrapper.o,include_type_definitions_p4.cmo,include_as_string_p4.cmo,where_p4.cmo,option_extract_p4.cmo,raise_p4.cmo,log_module_loading_p4.cmo} MANUALLY_PRE_COPY_IN_build = \ GETTEXT/gettext_extract_pot_p4.ml{,i} \ GETTEXT/gettext-c-wrapper.c \ EXTRA/does-process-exist-c-wrapper.c \ EXTRA/waitpid-c-wrapper.c \ CAMLP4/include_type_definitions_p4.ml{,i} \ CAMLP4/include_as_string_p4.ml{,i} \ CAMLP4/where_p4.ml{,i} \ CAMLP4/option_extract_p4.ml{,i} \ CAMLP4/common_tools_for_preprocessors.ml{,i} \ CAMLP4/raise_p4.ml{,i} \ CAMLP4/log_module_loading_p4.ml{,i} MANUALLY_PRE_MAKE_IN_build = \ gettext_extract_pot_p4.cm{i,o} \ include_type_definitions_p4.cm{i,o} \ include_as_string_p4.cm{i,o} \ where_p4.cm{i,o} \ option_extract_p4.cm{i,o} \ raise_p4.cm{i,o} \ log_module_loading_p4.cm{i,o} \ libocamlbricks_stubs.a main-local: meta_ocamlbricks.ml meta_ocamlbricks.ml: meta.ml cp $< meta_ocamlbricks.ml EXCLUDE_FROM_EDITING=meta_ocamlbricks.ml # include_type_definitions_p4 _build/include_type_definitions_p4.cmi: CAMLP4/include_type_definitions_p4.mli ocamlc -c -I +camlp4 -pp '$(PP_OPTION)' -o $@ $< _build/include_type_definitions_p4.cmo: CAMLP4/include_type_definitions_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp '$(PP_OPTION)' -o $@ $< # include_as_string_p4 _build/include_as_string_p4.cmi: CAMLP4/include_as_string_p4.mli ocamlc -c -I +camlp4 -pp '$(PP_OPTION)' -o $@ $< _build/include_as_string_p4.cmo: CAMLP4/include_as_string_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp '$(PP_OPTION)' -o $@ $< _build/where_p4.cmi: CAMLP4/where_p4.mli ocamlc -c -I +camlp4 -pp camlp4of -o $@ $< _build/where_p4.cmo: CAMLP4/where_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/option_extract_p4.cmi: CAMLP4/option_extract_p4.mli ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/option_extract_p4.cmo: CAMLP4/option_extract_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/raise_p4.cmi: CAMLP4/raise_p4.mli ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/raise_p4.cmo: CAMLP4/raise_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/log_module_loading_p4.cmi: CAMLP4/log_module_loading_p4.mli ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/log_module_loading_p4.cmo: CAMLP4/log_module_loading_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< # gettext_extract_pot_p4 _build/gettext_extract_pot_p4.cmi: $(GETTEXT)/gettext_extract_pot_p4.mli ocamlc -c -I +camlp4 -pp camlp4of camlp4lib.cma -o $@ $< _build/gettext_extract_pot_p4.cmo: $(GETTEXT)/gettext_extract_pot_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of camlp4lib.cma -o $@ $< _build/libocamlbricks_stubs.a: $(GETTEXT)/gettext-c-wrapper.c EXTRA/does-process-exist-c-wrapper.c EXTRA/waitpid-c-wrapper.c @(mkdir _build &> /dev/null || true); \ cd _build; \ ocamlc -c -verbose $(GETTEXT)/gettext-c-wrapper.c; \ ocamlc -c -verbose EXTRA/does-process-exist-c-wrapper.c; \ ocamlc -c -verbose EXTRA/waitpid-c-wrapper.c; \ ocamlmklib -verbose -oc ocamlbricks_stubs gettext-c-wrapper.o does-process-exist-c-wrapper.o waitpid-c-wrapper.o # idempotent rebuilding: @chmod +x Makefile.d/ocamlmklib_wrapper.sh @Makefile.d/ocamlmklib_wrapper.sh $(C_OBJECTS_TO_LINK) preprocessors: _build/gettext_extract_pot_p4.cmo install-libraries-local: rebuilding preprocessors # Remove the automatically-generated documentation on clean: clean-local: @(rm -rf doc/html) rm -f meta_ocamlbrics.ml _build/meta_ocamlbrics.ml rm -rf _build/does_process_exist.o rm -rf _build/waitpid-c-wrapper.o compile_for_testing: @if grep -q "DDOCUMENTATION_OR_DEBUGGING" $(LOGFILE); then echo "Fine, already compiled for testing."; else make clean; fi; \ make PP_OPTION="$(PP_OPTION) -DDOCUMENTATION_OR_DEBUGGING" # Test without installation LIBRARY_TO_TEST=_build/ocamlbricks.cma test: compile_for_testing rebuilding @chmod +x Makefile.d/test_with.sh @Makefile.d/test_with.sh "ocaml" # Test without installation with the utop toplevel test_with_utop: compile_for_testing rebuilding @chmod +x Makefile.d/test_with.sh @Makefile.d/test_with.sh "utop" # Test without installation with the utop toplevel test_with_utop+widgets: compile_for_testing rebuilding @chmod +x Makefile.d/test_with.sh @Makefile.d/test_with.sh "utop" "lablgtk2" ocamlbricks-0.90+bzr456.orig/MAKE/0000755000175000017500000000000013175721005015440 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/MAKE/crep.ml0000644000175000017500000000237113175721005016726 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** This simple program run as the famous {b grep} command but taking a regular expression in the [Str] O'Caml library format. The regular expression must be given as the first and unique argument. The parsed file is the standard input. *) let main () = let re = Str.regexp (Sys.argv.(1)) in let rec boucle () = try begin let line = read_line () in (match Str.string_match re line 0 with | true -> print_endline line | false -> ()); boucle () end with End_of_file -> () in boucle () ;; main () ;; ocamlbricks-0.90+bzr456.orig/DOT/0000755000175000017500000000000013175721005015351 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/DOT/dot_widget.mli0000644000175000017500000000243013175721005020204 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Widgets for dot. *) val filter_of_format : Dot.output_format -> GFile.filter val filter_of_string : string -> GFile.filter val make_all_working_filters : unit -> GFile.filter list val make_all_working_filters_assoc : unit -> (Dot.output_format * GFile.filter) list val combo_of_working_output_formats : ?active:Dot.output_format -> ?add_tearoffs:bool -> ?focus_on_click:bool -> ?has_frame:bool -> ?wrap_width:int -> ?width:int -> ?height:int -> ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> GEdit.combo_box * (unit -> Dot.output_format) ocamlbricks-0.90+bzr456.orig/DOT/dot.mli0000644000175000017500000011673213175721005016654 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Simplified interface (forgetting options): {[ val graph : ?... -> statement list -> graph val subgraph : ?... -> statement list -> statement val cluster : ?... -> statement list -> statement val node : ?... -> node_ident -> statement val edge : ?... -> node_ident -> node_ident -> statement val graph_default : ?... -> unit -> statement val node_default : ?... -> unit -> statement val edge_default : ?... -> unit -> statement val label_of_text : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> text -> [ `html of html_like ] val label_of_table : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> table -> [ `html of html_like ] val html_of_text : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> text -> html_like val html_of_table : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> table -> html_like val text_of_string : ?br:unit -> ?align:[ `CENTER | `LEFT | `RIGHT ] -> string -> text val text_concat : text list -> text val table : ?... -> row list -> table val cell_of_text : ?... -> text -> cell val cell_of_table : ?... -> table -> cell val cell_of_image : ?... -> filename -> cell val print : graph -> unit val fprint : filename -> graph -> unit val sprint : graph -> string ]} *) type graph type statement type color = [ `RGB of int * int * int | `HSV of float*float*float | `name of string ] type filename = string type ident = string type layer_ident = string type point_ident = string type port_ident = string type node_ident = string type cluster_ident = string type escaped_string = string (* string allowing escape sequences which are replaced according to the context. For node attributes, the substring "\N" is replaced by the name of the node, and the substring "\G" by the name of the graph. For graph or cluster attributes, the substring "\G" is replaced by the name of the graph or cluster. For edge attributes, the substring "\N" is replaced by the name of the edge, and the substrings "\T" and "\H" by the names of the tail and head nodes, respectively. The name of an edge is the string formed from the name of the tail node, the appropriate edge operator ("--" or "->") and the name of the head node. In addition, if the associated attribute is label, headlabel or taillabel, the escape sequences "\n", "\l" and "\r" divide the label into lines, centered, left-justified, and right-justified, respectively. *) (* See http://www.graphviz.org/pub/scm/graphviz2/doc/info/shapes.html#html *) type html_like = [ `text of text | `TABLE of table | `FONT of font ] and text = item list and item = [ `string of string | `BR of br_attribute list ] and table = table_attribute list * row list and table_attribute = [ `ALIGN of [`CENTER|`LEFT|`RIGHT] | `BGCOLOR of color | `BORDER of float | `CELLBORDER of float | `CELLPADDING of float | `CELLSPACING of float | `FIXEDSIZE of bool | `HEIGHT of float | `HREF of string | `PORT of string | `TARGET of string | `TITLE of string | `TOOLTIP of string | `VALIGN of [ `MIDDLE|`BOTTOM|`TOP ] | `WIDTH of float ] and font = font_attribute list * html_like and font_attribute = [ `COLOR of color | `FACE of string | `POINT_SIZE of int ] and br_attribute = [ `ALIGN of [`CENTER|`LEFT|`RIGHT] ] and row = cell list and cell = cell_attribute list * [ `html of html_like | `IMG of image ] and cell_attribute = [ `ALIGN of [`CENTER|`LEFT|`RIGHT] | `BGCOLOR of color | `BORDER of float | `CELLPADDING of float | `CELLSPACING of float | `FIXEDSIZE of bool | `HEIGHT of float | `HREF of string | `PORT of string | `TARGET of string | `TITLE of string | `TOOLTIP of string | `VALIGN of [ `MIDDLE|`BOTTOM|`TOP ] | `WIDTH of float (* cell specific: *) | `COLSPAN of int | `ROWSPAN of int ] and image = image_attribute list and image_attribute = [ `SCALE of [`FALSE|`TRUE|`WIDTH|`HEIGHT|`BOTH] | `SRC of filename ] type label = [ `escaped of escaped_string | `html of html_like ] (** Graph constructor. *) val graph: ?strict:unit -> (* If the graph is strict then multiple edges are not allowed between the same pairs of nodes. *) ?digraph:bool -> (* If it is a directed graph, indicated by digraph, then the edgeop must be "->". If it is an undirected graph then the edgeop must be "--". *) ?name:ident -> ?size:[ `max of (float*float) | `force of (float*float) ] -> (* size="x,y" sets bounding box of drawing in inches. Maximum width and height of drawing, in inches. If defined and the drawing is too large, the drawing is uniformly scaled down so that it fits within the given size. If size ends in an exclamation point (!), then it is taken to be the desired size. In this case, if both dimensions of the drawing are less than size, the drawing is scaled up uniformly until at least one dimension equals its dimension in size. Note that there is some interaction between the size and ratio attributes. *) ?page:(float*float) -> (* page="x,y" sets the PostScript pagination unit. Width and height of output pages, in inches. If this is set and is smaller than the size of the layout, a rectangular array of pages of the specified page size is overlaid on the layout, with origins aligned in the lower-left corner, thereby partitioning the layout into pages. The pages are then produced one at a time, in pagedir order. *) ?pagedir: [ `BL | `BR | `TL | `TR | `RB | `RT | `LB | `LT ] -> (* pagedir "BL", "BR", "TL", "TR", "RB", "RT", "LB", "LT" specify the 8 row or column major orders for traversing a rectangular array, the first character corresponding to the major order and the second to the minor order. Thus, for "BL", the major order is from bottom to top, and the minor order is from left to right. This means the bottom row is traversed first, from left to right, then the next row up, from left to right, and so on, until the topmost row is traversed. *) ?rotate:float -> (* rotate=90 sets landscape mode. *) ?ratio:[ `float of float | `fill | `compress | `auto ] -> (* ratio=f sets the aspect ratio (drawing height/drawing width) for the drawing. Note that this is adjusted before the size attribute constraints are enforced. - If ratio is numeric, it is taken as the desired aspect ratio. Then, if the actual aspect ratio is less than the desired ratio, the drawing height is scaled up to achieve the desired ratio; if the actual ratio is greater than that desired ratio, the drawing width is scaled up. - If ratio = "fill" and the size attribute is set, node positions are scaled, separately in both x and y, so that the final drawing exactly fills the specified size. - If ratio = "compress" and the size attribute is set, dot attempts to compress the initial layout to fit in the given size. This achieves a tighter packing of nodes but reduces the balance and symmetry. This feature only works in dot. - If ratio = "expand", the size attribute is set, and both the width and the height of the graph are less than the value in size, node positions are scaled uniformly until at least one dimension fits size exactly. Note that this is distinct from using size as the desired size, as here the drawing is expanded before edges are generated and all node and text sizes remain unchanged. - If ratio = "auto", the page attribute is set and the graph cannot be drawn on a single page, then size is set to an ``ideal'' value. In particular, the size in a given dimension will be the smallest integral multiple of the page size in that dimension which is at least half the current size. The two dimensions are then scaled independently to the new size. This feature only works in dot. *) ?margin:(float*float) -> (* For graphs, this sets x and y margins of canvas, in inches. *) ?center:unit -> (* If true, the drawing is centered in the output canvas. *) ?nodesep:float -> (* nodesep=f set the minimum space between two adjacent nodes in the same rank, in inches. Default 0.25, minimum 0.02 *) ?ordering:[ `inp | `out ] -> (* If "out" for a graph G, and n is a node in G, then edges n->* appear left-to-right in the same order in which they are defined. If "in", the edges *->n appear left-to-right in the same order in which they are defined for all nodes n. *) ?outputorder: [ `breadthfirst | `nodesfirst | `edgesfirst ] -> (* Specify order in which nodes and edges are drawn. "breadthfirst","nodesfirst","edgesfirst" specify the order in which nodes and edges are drawn in concrete output. The default "breadthfirst" is the simplest, but when the graph layout does not avoid edge-node overlap, this mode will sometimes have edges drawn over nodes and sometimes on top of nodes. If the mode "nodesfirst" is chosen, all nodes are drawn first, followed by the edges. This guarantees an edge-node overlap will not be mistaken for an edge ending at a node. On the other hand, usually for aesthetic reasons, it may be desirable that all edges appear beneath nodes, even if the resulting drawing is ambiguous. This can be achieved by choosing "edgesfirst". *) ?rank: [ `same | `min | `max | `source | `sink ] -> (* rank=.. Rank constraints on the nodes in a subgraph. If rank="same", all nodes are placed on the same rank. If rank="min", all nodes are placed on the minimum rank. If rank="source", all nodes are placed on the minimum rank, and the only nodes on the minimum rank belong to some subgraph whose rank attribute is "source" or "min". Analogous criteria hold for rank="max" and rank="sink". (Note: the minimum rank is topmost or leftmost, and the maximum rank is bottommost or rightmost.) *) ?rankdir: [`TB|`LR|`RL|`BT] -> (* rankdir=LR|RL|BT requests a left‐to‐right, right‐to‐left, or bottom‐to‐top, drawing. *) ?ranksep:float -> (* ranksep=f sets the minimum separation between ranks. Default 0.5. *) ?clusterrank:[ `local | `global | `none ] -> (* Mode used for handling clusters. If clusterrank is "local", a subgraph whose name begins with "cluster" is given special treatment. The subgraph is laid out separately, and then integrated as a unit into its parent graph, with a bounding rectangle drawn about it. If the cluster has a label parameter, this label is displayed within the rectangle. Note also that there can be clusters within clusters. At present, the modes "global" and "none" appear to be identical, both turning off the special cluster processing. *) ?nslimit:float -> (* nslimit=f adjusts the bound on the number of network simplex or min‐cross iterations by the given ratio. *) ?layers:layer_ident list -> (* graph layers declarations. See http://www.graphviz.org/Documentation/html/layers/ *) ?color:color -> (* color=colorvalue sets foreground color. This is the basic drawing color for graphics, not text. For the latter, use the fontcolor attribute. For edges, the value can either be a single color or a colorList. In the latter case, the edge is drawn using parallel splines or lines, one for each color in the list, in the order given. *) ?bgcolor:color -> (* bgcolor=colorvalue sets background color. When attached to the root graph, this color is used as the background for entire canvas. When a cluster attribute, it is used as the initial background for the cluster. If a cluster has a filled style, the cluster's fillcolor will overlay the background color. If no background color is specified for the root graph, no graphics operation are performed on the background. This works fine for PostScript but for bitmap output, all bits are initialized to something. This means that when the bitmap output is included in some other document, all of the bits within the bitmap's bounding box will be set, overwriting whatever color or graphics where already on the page. If this effect is not desired, and you only want to set bits explicitly assigned in drawing the graph, set background="transparent". *) ?href:string -> (* href="url" the default url for image map files; in PostScript files, the base URL for all relative URLs, as recognized by Acrobat Distiller 3.0 and up. *) ?url:escaped_string -> (* Hyperlinks incorporated into device-dependent output. At present, used in ps2, cmap, i*map and svg formats. For all these formats, URLs can be attached to nodes, edges and clusters. URL attributes can also be attached to the root graph in ps2, cmap and i*map formats. This serves as the base URL for relative URLs in the former, and as the default image map file in the latter. The active area for a node or cluster is its bounding box. For edges, the active areas are small circles where the edge contacts its head and tail nodes. These areas may overlap the related node, and the edge URL dominates. If the edge has a label, this will also be active. Finally, if the edge has a head or tail label, this will also be active. Note, however, that if the edge has a headURL attribute, it is this value that is used near the head node and on the head label, if defined. The similar restriction holds when tailURL is defined. The URL of the root graph is only treated as an escString if the output format is cmap. *) ?stylesheet:string -> (* stylesheet="file.css" includes a reference to a stylesheet in -Tsvg and -Tsvgz outputs. Ignored by other formats. *) ?charset:string -> (* Specifies the character encoding used when interpreting string input as a text label. The default value is "UTF-8". The other legal value is "iso-8859-1" or, equivalently, "Latin1". The charset attribute is case-insensitive. Note that if the character encoding used in the input does not match the charset value, the resulting output may be very strange. *) ?comment: string -> (* Comments are inserted into output. Device-dependent *) ?compound: unit -> (* If true, allow edges between clusters. (See lhead and ltail). *) ?concentrate: unit -> (* If true, use edge concentrators. *) ?fontcolor: color -> (* Color used for text. *) ?fontname:string -> (* Font used for text. This very much depends on the output format and, for non-bitmap output such as PostScript or SVG, the availability of the font when the graph is displayed or printed. As such, it is best to rely on font faces that are generally available, such as Times-Roman, Helvetica or Courier. *) ?fontpath:string list -> (* Directory list used by libgd to search for bitmap fonts if Graphviz was not built with the fontconfig library. If fontpath is not set, the environment variable DOTFONTPATH is checked. If that is not set, GDFONTPATH is checked. If not set, libgd uses its compiled-in font path. Note that fontpath is an attribute of the root graph. *) ?fontsize:int -> (* Font size, in points, used for text. Default is 14.0, minimum is 1.0 *) ?label: label -> (* Text label attached to objects. *) ?labeljust: [ `r | `l | `c ] -> (* Justification for cluster labels. If "r", the label is right-justified within bounding rectangle; if "l", left-justified; else the label is centered. Note that a subgraph inherits attributes from its parent. Thus, if the root graph sets labeljust to "l", the subgraph inherits this value. *) ?labelloc: [ `t | `b ] -> (* Top/bottom placement of graph and cluster labels. If the attribute is "t", place label at the top; if the attribute is "b", place label at the bottom. By default, root graph labels go on the bottom and cluster labels go on the top. Note that a subgraph inherits attributes from its parent. Thus, if the root graph sets labelloc to "b", the subgraph inherits this value. Default is "b" for root graphs. *) ?nojustify:unit -> (* By default, the justification of multi-line labels is done within the largest context that makes sense. Thus, in the label of a polygonal node, a left-justified line will align with the left side of the node (shifted by the prescribed margin). In record nodes, left-justified line will line up with the left side of the enclosing column of fields. If nojustify is "true", multi-line labels will be justified in the context of itself. For example, if the attribute is set, the first label line is long, and the second is shorter and left-justified, the second will align with the left-most character in the first line, regardless of how large the node might be. *) ?quantum:float -> (* If quantum > 0.0, node label dimensions will be rounded to integral multiples of the quantum. *) ?remincross:unit -> (* If true and there are multiple clusters, run cross minimization a second time. *) ?samplepoints: int -> (* If the input graph defines the ?vertices attribute, and output is dot or xdot, this give the number of points used to represent circles and ellipses. It plays the same role in neato, when adjusting the layout to avoid overlapping nodes. Default 8. *) statement list -> graph val subgraph: ?name:ident -> ?rank: [ `same | `min | `max | `source | `sink ] -> (* rank=.. Rank constraints on the nodes in a subgraph. If rank="same", all nodes are placed on the same rank. If rank="min", all nodes are placed on the minimum rank. If rank="source", all nodes are placed on the minimum rank, and the only nodes on the minimum rank belong to some subgraph whose rank attribute is "source" or "min". Analogous criteria hold for rank="max" and rank="sink". (Note: the minimum rank is topmost or leftmost, and the maximum rank is bottommost or rightmost.) *) statement list -> statement (* See http://www.graphviz.org/Gallery/directed/cluster.html *) val cluster: ?name_suffix:cluster_ident -> ?rank: [ `same | `min | `max | `source | `sink ] -> ?color:color -> ?bgcolor:color -> ?fillcolor: color -> (* Color used to fill the background of a node or cluster. If fillcolor is not defined, color is used. (For clusters, if color is not defined, bgcolor is used.) If this is not defined, the default is used, except for shape=point or when the output format is MIF, which use black by default. Note that a cluster inherits the root graph's attributes if defined. Thus, if the root graph has defined a fillcolor, this will override a color or bgcolor attribute set for the cluster. Default is black for clusters. *) ?pencolor:color -> (* Color used to draw the bounding box around a cluster. If pencolor is not defined, color is used. If this is not defined, bgcolor is used. If this is not defined, the default is used. Note that a cluster inherits the root graph's attributes if defined. Thus, if the root graph has defined a pencolor, this will override a color or bgcolor attribute set for the cluster. *) ?fontcolor: color -> ?fontname:string -> (* Default is "Times-Roman" *) ?fontsize:int -> ?label: label -> ?labeljust: [ `r | `l | `c ] -> ?labelloc: [ `t | `b ] -> (* Default is "t" for clusters. *) ?nojustify:unit -> ?url:escaped_string -> ?peripheries: int -> (* Set number of peripheries used in polygonal shapes and cluster boundaries. Note that user-defined shapes are treated as a form of box shape, so the default peripheries value is 1 and the user-defined shape will be drawn in a bounding rectangle. Setting peripheries=0 will turn this off. Also, 1 is the maximum peripheries value for clusters. Default is 1 for clusters *) ?style: [ `filled | `rounded ] list -> (* For cluster subgraph, if "filled", the cluster box's background is filled. *) statement list -> statement val node : ?url:escaped_string -> ?color:color -> ?comment: string -> ?distortion:float -> (* Distortion factor for shape=polygon. Positive values cause top part to be larger than bottom; negative values do the opposite. Default is 0.0, maximum is 100.0 *) ?fillcolor: color -> (* Default is lightgrey for nodes *) ?fontcolor: color -> ?fontname:string -> ?fontsize:int -> ?fixedsize:unit -> (* If true, the node size is specified by the values of the width and height attributes only and is not expanded to contain the text label. *) ?group:string -> (* If the end points of an edge belong to the same group, i.e., have the same group attribute, parameters are set to avoid crossings and keep the edges straight. *) ?height:float -> (* Height of node, in inches. This is taken as the initial, minimum height of the node. If fixedsize is true, this will be the final height of the node. Otherwise, if the node label requires more height to fit, the node's height will be increased to contain the label. Note also that, if the output format is dot, the value given to height will be the final value. Default is 0.5, maximum is 0.02. *) ?layer: layer_ident list -> (* Specifies layers in which the node or edge is present. *) ?margin:(float*float) -> (* For nodes, this attribute specifies space left around the node's label. By default, the value is 0.11,0.055. *) ?nojustify:unit -> ?orientation:float -> (* Angle, in degrees, used to rotate node shapes. Default is 0.0, maximum is 360.0 *) ?peripheries: int -> (* Default is shape default for nodes *) ?pos:float*float -> (* Set the position of node in points. Concerning this, see the -s command line flag. *) ?regular:unit -> (* Force polygon to be regular. *) ?shape: [ `box | `ellipse | `circle | `point | `egg | `triangle | `plaintext | `diamond | `trapezium | `parallelogram | `house | `pentagon | `hexagon | `septagon | `octagon | `doublecircle | `doubleoctagon | `tripleoctagon | `invtriangle | `invtrapezium | `invhouse | `Mdiamond | `Msquare | `Mcircle | `rect | `rectangle | `none | `epsf of filename (* shape=epsf, shapefile=filename *) | `polygon of int * int (* shape=polygon, sides=int, skew=int. Default are sides=4 and skew=0.0 *) ] -> (* Default is ellipse. See http://www.graphviz.org/pub/scm/graphviz2/doc/info/shapes.html#polygon *) (* Undocumented, but really nice: the image act as a background for the label. *) ?image:filename -> ?label: label -> (* Internal label. Default is "N" for nodes. *) ?style: [ `dashed | `dotted | `solid | `invis | `bold | `filled | `diagonals | `rounded ] list -> ?width:float -> (* Width of node, in inches. This is taken as the initial, minimum width of the node. If fixedsize is true, this will be the final width of the node. Otherwise, if the node label requires more width to fit, the node's width will be increased to contain the label. Note also that, if the output format is dot, the value given to width will be the final value. *) ?z:float -> (* Provides z coordinate value for 3D layouts and displays. If the graph has dim set to 3 (or more), neato will use a node's z value for the z coordinate of its initial position if its pos attribute is also defined. Even if no z values are specified in the input, it is necessary to declare a z attribute for nodes, e.g, using node[z=""] in order to get z values on output. Thus, setting dim=3 but not declaring z will cause neato -Tvrml to layout the graph in 3D but project the layout onto the xy-plane for the rendering. If the z attribute is declared, the final rendering will be in 3D. *) ?outlabel:[ `north of label | `south of label | `east of label | `west of label ] -> node_ident -> statement val edge : ?url:escaped_string -> ?color:color -> ?comment: string -> ?arrowhead: [ `normal | `inv | `dot | `invdot | `odot | `invodot | `none | `tee | `empty | `invempty | `diamond | `odiamond | `ediamond | `crow | `box | `obox | `Open | `halfopen | `vee ] -> (* Style of arrowhead on the head node of an edge. Default is normal. See: http://www.graphviz.org/pub/scm/graphviz2/doc/info/attrs.html#k:arrowType *) ?arrowtail: [ `normal | `inv | `dot | `invdot | `odot | `invodot | `none | `tee | `empty | `invempty | `diamond | `odiamond | `ediamond | `crow | `box | `obox | `Open | `halfopen | `vee ] -> (* Style of arrowhead on the tail node of an edge. Default is normal. See: http://www.graphviz.org/pub/scm/graphviz2/doc/info/attrs.html#k:arrowType *) ?dir: [ `forward | `back | `both | `none ] -> (* Default is forward fo directed graphs *) ?arrowsize:float -> (* Multiplicative scale factor for arrowheads. Default is 1.0 *) ?constraint_off:unit -> (* Dot attribute is simply "constraint" which is an OCaml keyword. If set, the edge is not used in ranking the nodes. *) ?decorate:unit -> (* Attach edge label to edge by a 2-segment polyline, underlining the label, then going to the closest point of spline. *) ?fontcolor: color -> ?fontname:string -> ?fontsize:int -> (* Default is 14.0, minimum is 1.0. *) ?headclip:bool -> (* If true, the head of an edge is clipped to the boundary of the head node; otherwise, the end of the edge goes to the center of the node, or the center of a port, if applicable. Default is true. *) ?headlabel: label -> (* Text label to be placed near head of edge. *) ?headport: port_ident * ([ `n | `ne | `e | `se | `s | `sw | `w | `nw ] option) -> (* Indicates where on the head node to attach the head of the edge. In the default case, the edge is aimed towards the center of the node, and then clipped at the node boundary. The optional modifier indicating where on a node an edge should be aimed. It has the form portname[:compass_point] or compass_point. If the first form is used, the corresponding node must either have record shape with one of its fields having the given portname, or have an HTML-like label, one of whose components has a PORT attribute set to portname. In this case, the edge is aimed for the center of the corresponding field. If a compass point is used, it must have the form "n","ne","e","se","s","sw","w","nw". This modifies the edge placement to aim for the corresponding compass point on the port or, in the second form where no portname is supplied, on the node itself. This attribute can be attached to an edge using the headport and tailport attributes, or as part of the edge description as in node1:port1 -> node2:port5:nw. Default is center. *) ?tailclip:bool -> ?taillabel: label -> ?tailport: port_ident * ([ `n | `ne | `e | `se | `s | `sw | `w | `nw ] option) -> ?label: label -> (* Default is the empty string for edges. *) ?labelangle:float -> (* This, along with labeldistance, determine where the headlabel (taillabel) are placed with respect to the head (tail) in polar coordinates. The origin in the coordinate system is the point where the edge touches the node. The ray of 0 degrees goes from the origin back along the edge, parallel to the edge at the origin. The angle, in degrees, specifies the rotation from the 0 degree ray, with positive angles moving counterclockwise and negative angles moving clockwise. Default is -25.0, minimum is -180.0 *) ?labeldistance:float -> (* Multiplicative scaling factor adjusting the distance that the headlabel(taillabel) is from the head(tail) node. The default distance is 10 points. See labelangle for more details. Default is 1.0. *) ?labelfloat:unit -> (* Allows edge labels to be less constrained in position. In particular, it may appear on top of other edges. *) ?labelfontcolor: color -> (* Color used for headlabel and taillabel. If not set, defaults to edge's fontcolor. Default is black. *) ?labelfontname:string -> (* Font used for headlabel and taillabel. If not set, defaults to edge's fontname. *) ?labelfontsize:int -> (* Font size, in points, used for headlabel and taillabel. If not set, defaults to edge's fontsize. *) ?layer: layer_ident list -> (* Specifies layers in which the node or edge is present. *) ?lhead:cluster_ident -> (* Logical head of an edge. When the graph option "compound" is true, if lhead is defined and is the name of a cluster containing the real head, the edge is clipped to the boundary of the cluster. *) ?ltail:cluster_ident -> (* Logical tail of an edge. When compound is true, if ltail is defined and is the name of a cluster containing the real tail, the edge is clipped to the boundary of the cluster. *) ?minlen:int -> (* Minimum edge length (rank difference between head and tail). *) ?nojustify:unit -> ?pos:float*float -> (* Set the position of spline control points in points. Concerning this, see the -s command line flag. *) ?samehead:point_ident -> (* Edges with the same head and the same samehead value are aimed at the same point on the head. *) ?sametail:point_ident -> (* Edges with the same tail and the same sametail value are aimed at the same point on the tail. *) ?style: [ `dashed | `dotted | `solid | `invis | `bold ] list -> ?weight:float -> (* Weight of edge. In dot, the heavier the weight, the shorter, straighter and more vertical the edge is. Default is 1.0, minimum is 0. *) node_ident -> node_ident -> statement val graph_default : ?size:[ `max of (float*float) | `force of (float*float) ] -> ?page:(float*float) -> ?pagedir: [ `BL | `BR | `TL | `TR | `RB | `RT | `LB | `LT ] -> ?rotate:float -> ?ratio:[ `float of float | `fill | `compress | `auto ] -> ?margin:(float*float) -> ?center:unit -> ?nodesep:float -> ?ordering:[ `inp | `out ] -> ?outputorder: [ `breadthfirst | `nodesfirst | `edgesfirst ] -> ?rank: [ `same | `min | `max | `source | `sink ] -> ?rankdir: [`TB|`LR|`RL|`BT] -> ?ranksep:float -> ?clusterrank:[ `local | `global | `none ] -> ?nslimit:float -> ?layers:layer_ident list -> ?color:color -> ?bgcolor:color -> ?href:string -> ?url:escaped_string -> ?stylesheet:string -> ?charset:string -> ?comment: string -> ?compound: unit -> ?concentrate: unit -> ?fontcolor: color -> ?fontname:string -> ?fontpath:string list -> ?fontsize:int -> ?label: label -> ?labeljust: [ `r | `l | `c ] -> ?labelloc: [ `t | `b ] -> ?nojustify:unit -> ?quantum:float -> ?remincross:unit -> ?samplepoints: int -> unit -> statement val node_default : ?url:escaped_string -> ?color:color -> ?comment: string -> ?distortion:float -> ?fillcolor: color -> ?fontcolor: color -> ?fontname:string -> ?fontsize:int -> ?fixedsize:unit -> ?group:string -> ?height:float -> ?layer: layer_ident list -> ?margin:(float*float) -> ?nojustify:unit -> ?orientation:float -> ?peripheries: int -> ?pos:float*float -> ?regular:unit -> ?shape: [ `box | `ellipse | `circle | `point | `egg | `triangle | `plaintext | `diamond | `trapezium | `parallelogram | `house | `pentagon | `hexagon | `septagon | `octagon | `doublecircle | `doubleoctagon | `tripleoctagon | `invtriangle | `invtrapezium | `invhouse | `Mdiamond | `Msquare | `Mcircle | `rect | `rectangle | `none | `epsf of filename (* shape=epsf, shapefile=filename *) | `polygon of int * int (* shape=polygon, sides=int, skew=int. Default are sides=4 and skew=0.0 *) ] -> ?image:filename -> ?label: label -> ?style: [ `dashed | `dotted | `solid | `invis | `bold | `filled | `diagonals | `rounded ] list -> ?width:float -> ?z:float -> unit -> statement val edge_default : ?url:escaped_string -> ?color:color -> ?comment: string -> ?arrowhead: [ `normal | `inv | `dot | `invdot | `odot | `invodot | `none | `tee | `empty | `invempty | `diamond | `odiamond | `ediamond | `crow | `box | `obox | `Open | `halfopen | `vee ] -> ?arrowtail: [ `normal | `inv | `dot | `invdot | `odot | `invodot | `none | `tee | `empty | `invempty | `diamond | `odiamond | `ediamond | `crow | `box | `obox | `Open | `halfopen | `vee ] -> ?dir: [ `forward | `back | `both | `none ] -> ?arrowsize:float -> ?constraint_off:unit -> ?decorate:unit -> ?fontcolor: color -> ?fontname:string -> ?fontsize:int -> ?headclip:bool -> ?headlabel: label -> ?headport: port_ident * ([ `n | `ne | `e | `se | `s | `sw | `w | `nw ] option) -> ?tailclip:bool -> ?taillabel: label -> ?tailport: port_ident * ([ `n | `ne | `e | `se | `s | `sw | `w | `nw ] option) -> ?label: label -> ?labelangle:float -> ?labeldistance:float -> ?labelfloat:unit -> ?labelfontcolor: color -> ?labelfontname:string -> ?labelfontsize:int -> ?layer: layer_ident list -> ?lhead:cluster_ident -> ?ltail:cluster_ident -> ?minlen:int -> ?nojustify:unit -> ?pos:float*float -> ?samehead:point_ident -> ?sametail:point_ident -> ?style: [ `dashed | `dotted | `solid | `invis | `bold ] list -> ?weight:float -> unit -> statement val label_of_text : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> text -> label val label_of_table : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> table -> label val label_of_image : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellborder:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?imagescale:[ `BOTH | `FALSE | `HEIGHT | `TRUE | `WIDTH ] -> filename -> label val html_of_text : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> text -> html_like val html_of_table : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> table -> html_like val html_of_label : ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> label -> html_like val text_of_string : ?br:unit -> ?align:[ `CENTER | `LEFT | `RIGHT ] -> string -> text val text_concat : text list -> text val table : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellborder:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> row list -> table val cell_of_text : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?colspan:int -> ?rowspan:int -> ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> text -> cell val cell_of_string : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?colspan:int -> ?rowspan:int -> ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> string -> cell val cell_of_table : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?colspan:int -> ?rowspan:int -> ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> table -> cell val cell_of_html : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?colspan:int -> ?rowspan:int -> ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> html_like -> cell val cell_of_label : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?colspan:int -> ?rowspan:int -> ?fontcolor:color -> ?fontname:string -> ?fontsize:int -> label -> cell val cell_of_image : ?align: [ `CENTER | `LEFT | `RIGHT ] -> ?valign:[ `BOTTOM | `MIDDLE | `TOP ] -> ?bgcolor:color -> ?border:float -> ?cellpadding:float -> ?cellspacing:float -> ?fixedsize:bool -> ?height:float -> ?href:string -> ?port:string -> ?target:string -> ?title:string -> ?tooltip:string -> ?width:float -> ?colspan:int -> ?rowspan:int -> ?imagescale:[ `BOTH | `FALSE | `HEIGHT | `TRUE | `WIDTH ] -> filename -> cell val print : graph -> unit val display : ?bg:unit -> ?silent:unit -> graph -> unit val fprint : filename -> graph -> unit val sprint : graph -> string val graph_of_list : (node_ident * node_ident) list -> graph type output_format = [ `bmp (* Windows Bitmap Format *) | `canon | `dot | `xdot (* DOT *) | `cmap (* Client-side imagemap (deprecated) *) | `dia (* Dia diagram creation program *) | `eps (* Encapsulated PostScript *) | `fig (* FIG *) | `gd | `gd2 (* GD/GD2 formats *) | `gif (* GIF *) | `hpgl (* HP-GL subset of PCL *) | `ico (* Icon Image File Format *) | `imap | `cmapx (* Server-side and client-side imagemaps *) | `imap_np | `cmapx_np (* Server-side and client-side imagemaps *) | `ismap (* Server-side imagemap (deprecated) *) | `jpg (* JPEG *) | `pdf (* Portable Document Format (PDF) *) | `plain | `plain_ext (* Simple text format *) | `png (* Portable Network Graphics format *) | `ps (* PostScript *) | `ps2 (* PostScript for PDF *) | `svg | `svgz (* Scalable Vector Graphics *) | `tiff (* TIFF (Tag Image File Format) *) | `vml | `vmlz (* Vector Markup Language (VML) *) | `vrml (* VRML *) | `wbmp (* Wireless BitMap format *) (* The following provoke an long time (infinite?) execution: *) (* | `xlib (* Xlib canvas *) *) ] val string_of_output_format : output_format -> string val output_format_of_string : string -> output_format val output_format_description : output_format -> string val admissible_output_formats : output_format list val admissible_output_formats_as_strings : string list val make_image : ?silent:unit -> (* Hide dot errors or warnings *) ?dotfile:filename -> ?imgfile:filename -> ?imgtype:output_format -> (* by default `png *) graph -> (filename * filename) (** Return a 4-tuple (output, as_string, description, file_command_output) *) val working_output_formats : ?no_file_inspection:unit -> unit -> (output_format * string * string * string) list val working_output_formats_as_objects : ?no_file_inspection:unit -> unit -> < output_format : output_format; output_format_as_string : string; description : string; file_command_output : string; > list ocamlbricks-0.90+bzr456.orig/DOT/dot_widget.ml0000644000175000017500000000635313175721005020043 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) IFNDEF OCAML4_04_OR_LATER THEN let lowercase = String.lowercase let uppercase = String.uppercase let capitalize = String.capitalize ELSE let lowercase = String.lowercase_ascii let uppercase = String.uppercase_ascii let capitalize = String.capitalize_ascii ENDIF let make_dot_filter_by_format_and_description ~output_format_as_string ~description = let ext = output_format_as_string in let name = Printf.sprintf "%s (*.%s)" description ext in let patt1 = lowercase ext in let patt2 = uppercase ext in let patt3 = capitalize ext in let patterns = List.map (Printf.sprintf "*.%s") [patt1; patt2; patt3] in GFile.filter ~name ~patterns () let filter_of_format outfmt = let xyzw_list = Dot.working_output_formats ~no_file_inspection:() () in match ListExtra.search (fun (x,y,z,w) -> x=outfmt) xyzw_list with | None -> failwith "Dot_widget.filter_of_output_format" | Some (_, output_format_as_string, description, _) -> make_dot_filter_by_format_and_description ~output_format_as_string ~description let filter_of_string ext = let outfmt = Dot.output_format_of_string ext in filter_of_format outfmt let make_all_working_filters_assoc () = let xyzw_list = Dot.working_output_formats ~no_file_inspection:() () in List.map (fun (x,y,z,w) -> (x, make_dot_filter_by_format_and_description y z)) xyzw_list let make_all_working_filters () = let xyzw_list = Dot.working_output_formats ~no_file_inspection:() () in List.map (fun (x,y,z,w) -> make_dot_filter_by_format_and_description y z) xyzw_list let combo_of_working_output_formats ?(active:Dot.output_format option) ?add_tearoffs ?focus_on_click ?has_frame ?wrap_width ?width ?height ?packing ?show () = let xs = Dot.working_output_formats ~no_file_inspection:() () in let xa = Array.of_list xs in let strings = List.map (fun (frm, str, des, fil) -> let x = StringExtra.make_wide str 10 in Printf.sprintf "%s%s" x des) xs in let active = Option.bind active (fun act -> ListExtra.indexSuchThat (fun (frm,_,_,_) -> frm = act) xs) in let cb = GEdit.combo_box_text ~strings ~use_markup:true ?active ?add_tearoffs ?focus_on_click ?has_frame ?wrap_width ?width ?height ?packing ?show () in let get_active_output_format () = let index = (fst cb)#active in let (x,_,_,_) = xa.(index) in x in ((fst cb), get_active_output_format) ocamlbricks-0.90+bzr456.orig/DOT/dot.ml0000644000175000017500000011466113175721005016502 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo" ;; INCLUDE DEFINITIONS "../DOT/dot.mli" ;; type graph = { strict : bool; digraph : bool; name : name; statements : statement list; } and statement = | Graph_default of graph_option (* name=val *) | Graph_defaults of graph_option list (* graph [name=val,..] *) | Node_defaults of node_option list (* node [name=val,..] *) | Edge_defaults of edge_option list (* edge [name=val,..] *) | Node of node_ident * (node_option list) (* id [name=val,...] *) | Edge of node_ident * node_ident * (edge_option list) (* id -> id [name=val,...] *) | Subgraph of name * (statement list) (* subgraph name { statements } *) | Statement_list of statement list and name = string and graph_option = string and node_option = string and edge_option = string let commacat = String.concat "," let newlinecat = String.concat "\n" let rec cotokens_of_statement tab edge_operator = function | Graph_default graph_option -> [Printf.sprintf "%s%s" tab graph_option] | Graph_defaults graph_option_list -> [Printf.sprintf "%sgraph [%s]" tab (commacat graph_option_list)] | Node_defaults node_option_list -> [Printf.sprintf "%snode [%s]" tab (commacat node_option_list)] | Edge_defaults edge_option_list -> [Printf.sprintf "%sedge [%s]" tab (commacat edge_option_list)] | Node (node_ident, node_option_list) -> [Printf.sprintf "%s%s [%s]" tab node_ident (commacat node_option_list)] | Edge (n1, n2, edge_option_list) -> [Printf.sprintf "%s%s %s %s [%s]" tab n1 edge_operator n2 (commacat edge_option_list)] | Statement_list statement_list -> List.flatten (List.map (cotokens_of_statement tab edge_operator) statement_list) | Subgraph (name, statement_list) -> let tab' = (tab^" ") in let first = Printf.sprintf "%ssubgraph %s {" tab name in let last = Printf.sprintf "%s}" tab in let rest = ListExtra.flatten ~acc:[last] (List.map (cotokens_of_statement tab' edge_operator) statement_list) in first::rest let cotokens_of_graph { strict = strict; digraph = digraph; name = name; statements = statements; } = let strict = if strict then "strict " else "" in let (digraph, edge_operator) = if digraph then ("digraph","->") else ("graph","--") in let first = Printf.sprintf "%s%s %s {" strict digraph name in let last = Printf.sprintf "}" in let rest = ListExtra.flatten ~acc:[last] (List.map (cotokens_of_statement " " edge_operator) statements) in first::rest let print g = begin List.iter (Printf.printf "%s\n") (cotokens_of_graph g); flush stdout; end let fprint filename g = begin let ch = open_out filename in List.iter (Printf.fprintf ch "%s\n") (cotokens_of_graph g); flush ch; close_out ch; end let sprint g = newlinecat (cotokens_of_graph g) let string_of_output_format = function |`bmp-> "bmp" |`canon->"canon" |`dot->"dot" |`xdot->"xdot" |`cmap->"cmap" | `dia->"dia" |`eps->"eps" |`fig->"fig" |`gd->"gd" |`gd2->"gd2" |`gif->"gif" |`hpgl->"hpgl" |`ico->"ico" |`imap->"imap" |`cmapx->"cmapx" |`imap_np->"imap_np" |`cmapx_np->"cmapx_np" |`ismap->"ismap" |`jpg->"jpg" |`pdf->"pdf" |`plain->"plain" |`plain_ext->"plain_ext" |`png->"png" |`ps->"ps" |`ps2->"ps2" |`svg->"svg" |`svgz->"svgz" |`tiff->"tiff" |`vml->"vml" |`vmlz->"vmlz" |`vrml->"vrml" |`wbmp->"wbmp" (* |`xlib->"xlib" *) let output_format_of_string = function | "bmp" -> `bmp | "canon" -> `canon | "dot" -> `dot | "xdot" -> `xdot | "dia" -> `dia | "cmap" -> `cmap | "eps" -> `eps | "fig" -> `fig | "gd" -> `gd | "gd2" -> `gd2 | "gif" -> `gif | "hpgl" -> `hpgl | "ico" -> `ico | "imap" -> `imap | "cmapx" -> `cmapx | "imap_np" -> `imap_np | "cmapx_np" -> `cmapx_np | "ismap" -> `ismap | "jpg" -> `jpg | "pdf" -> `pdf | "plain" -> `plain | "plain_ext" -> `plain_ext | "png" -> `png | "ps" -> `ps | "ps2" -> `ps2 | "svg" -> `svg | "svgz" -> `svgz | "tiff" -> `tiff | "vml" -> `vml | "vmlz" -> `vmlz | "vrml" -> `vrml | "wbmp" -> `wbmp (* | "xlib" -> `xlib *) | _ -> raise Not_found let admissible_output_formats = [ `bmp; `canon; `dia; `dot; `xdot; `cmap; `eps; `fig; `gd; `gd2; `gif; `hpgl; `ico; `imap; `cmapx; `imap_np; `cmapx_np; `ismap; `jpg; `pdf; `plain; `plain_ext; `png; `ps; `ps2; `svg; `svgz; `tiff; `vml; `vmlz; `vrml; `wbmp; (*`xlib;*) ] let admissible_output_formats_as_strings = List.map string_of_output_format admissible_output_formats let output_format_description = function | `bmp -> "Windows Bitmap Format" | `canon | `dot | `xdot -> "Graphviz dot drawing program" | `cmap -> "Client-side imagemap (deprecated)" | `dia -> "Diagram creation program" | `eps -> "Encapsulated PostScript" | `fig -> "FIG vector drawing format" | `gd -> "GD graphics library format" | `gd2 -> "GD2 graphics library format" | `gif -> "GIF Graphics Interchange Format" | `hpgl -> "HP-GL subset of PCL" | `ico -> "Icon Image File Format" | `imap | `cmapx -> "Server- and client-side imagemaps" | `imap_np | `cmapx_np -> "Server- and client-side imagemaps" | `ismap -> "Server-side imagemap (deprecated)" | `jpg -> "JPEG Joint Photographic Group" | `pdf -> "PDF Portable Document Format" | `plain | `plain_ext -> "Simple text format" | `png -> "PNG Portable Network Graphics format" | `ps -> "PostScript" | `ps2 -> "PostScript for PDF" | `svg -> "Scalable Vector Graphics" | `svgz -> "Compressed Scalable Vector Graphics" | `tiff -> "TIFF Tag Image File Format" | `vml -> "VML Vector Markup Language" | `vmlz -> "VML Compressed Vector Markup Language" | `vrml -> "VRML Text file format" | `wbmp -> "Wireless BitMap format" (* | `xlib -> "Xlib canvas" *) let make_image ?silent ?dotfile ?imgfile ?(imgtype=`png) g = begin let imgtype = string_of_output_format imgtype in let dotfile = match dotfile with Some x -> x | None -> Filename.temp_file "Dot.make_image." ".dot" in let imgfile = match imgfile with Some x -> x | None -> Filename.temp_file "Dot.make_image." ("."^imgtype) in fprint dotfile g; let silent = match silent with None -> "" | Some () -> "2>/dev/null" in let cmd = Printf.sprintf "dot -T%s -o %s %s %s" imgtype imgfile dotfile silent in if (Sys.command cmd) <> 0 then failwith (Printf.sprintf "Dot.make_image: dot doesn't like this graph (file: %s)" dotfile) else (); (dotfile, imgfile) end let display_fg ~silent g = begin let dotfile = Filename.temp_file "Dot.display." ".dot" in let pngfile = Filename.temp_file "Dot.display." ".png" in fprint dotfile g; let cmd = Printf.sprintf "dot -Tpng -o %s %s %s" pngfile dotfile silent in if (Sys.command cmd) <> 0 then failwith (Printf.sprintf "Dot.display (fg): dot doesn't like this graph (file: %s)" dotfile) else (); let cmd = Printf.sprintf "display %s %s" pngfile silent in if (Sys.command cmd) <> 0 then failwith (Printf.sprintf "Dot.display (fg): display (imagemagick) doesn't like this png (file: %s)" pngfile) else (); Sys.remove dotfile; Sys.remove pngfile; end (* The temporary file is not deleted. The correct implementation should use threads (or futures). *) let display_bg ~silent g = begin let dotfile = "Dot.display.bg.dot" in fprint dotfile g; let cmd = Printf.sprintf "dot -Tpng %s %s | display %s &" dotfile silent silent in if (Sys.command cmd) <> 0 then failwith (Printf.sprintf "Dot.display (bg): something goes wrong (dotfile: %s)" dotfile) else (); end let display ?bg ?silent g = let silent = match silent with None -> "" | Some () -> "2>/dev/null" in match bg with None -> display_fg ~silent g | Some () -> display_bg ~silent g (* Common functions for further modules. *) module Common = struct let string_of_color = function | `RGB (r,g,b) -> Printf.sprintf "#%02x%02x%02x" r g b | `HSV (h,s,v) -> Printf.sprintf "%f %f %f" h s v | `name x -> x end module Html_like_constructors = struct let append_to_ref options inject opt = match opt with | None -> () | Some x -> (options := (inject x)::!options) let html_map f ?fontcolor ?fontname ?fontsize alpha : html_like = let font_attributes = ref [] in let append f x = append_to_ref font_attributes f x in append (fun x -> `COLOR x) fontcolor; append (fun x -> `FACE x) fontname; append (fun x -> `POINT_SIZE x) fontsize; match !font_attributes with | [] -> (f alpha) | fattrs -> (`FONT (fattrs, f alpha)) let html_of_text = let f x = `text x in html_map f let html_of_table = let f x = `TABLE x in html_map f let html_of_label = let f = function | (`escaped s) -> (`text [`string s]) | (`html h) -> h in html_map f let label_of_text ?fontcolor ?fontname ?fontsize x = `html (html_of_text ?fontcolor ?fontname ?fontsize x) let label_of_table ?fontcolor ?fontname ?fontsize x = `html (html_of_table ?fontcolor ?fontname ?fontsize x) let text_of_string ?br ?align s : text = let attributes = ref [] in let append f x = append_to_ref attributes f x in append (fun x -> `ALIGN x) align; match br with | None -> [ `string s ] | Some () -> [ `string s; `BR !attributes ] let text_concat (ts:text list) : text = List.flatten ts let table ?align ?valign ?bgcolor ?border ?cellborder ?cellpadding ?cellspacing ?fixedsize ?height ?href ?port ?target ?title ?tooltip ?width row_list : table = let attributes = ref [] in let append f x = append_to_ref attributes f x in append (fun x -> `ALIGN x) align; append (fun x -> `BGCOLOR x) bgcolor; append (fun x -> `BORDER x) border; append (fun x -> `CELLBORDER x) cellborder; append (fun x -> `CELLPADDING x) cellpadding; append (fun x -> `CELLSPACING x) cellspacing; append (fun x -> `FIXEDSIZE x) fixedsize; append (fun x -> `HEIGHT x) height; append (fun x -> `HREF x) href; append (fun x -> `PORT x) port; append (fun x -> `TARGET x) target; append (fun x -> `TITLE x) title; append (fun x -> `TOOLTIP x) tooltip; append (fun x -> `VALIGN x) valign; append (fun x -> `WIDTH x) width; (!attributes, row_list) let cell_map f ?align ?valign ?bgcolor ?border ?cellpadding ?cellspacing ?fixedsize ?height ?href ?port ?target ?title ?tooltip ?width ?colspan ?rowspan ?fontcolor ?fontname ?fontsize alpha : cell = let attributes = ref [] in let append f x = append_to_ref attributes f x in append (fun x -> `ALIGN x) align; append (fun x -> `BGCOLOR x) bgcolor; append (fun x -> `BORDER x) border; append (fun x -> `CELLPADDING x) cellpadding; append (fun x -> `CELLSPACING x) cellspacing; append (fun x -> `FIXEDSIZE x) fixedsize; append (fun x -> `HEIGHT x) height; append (fun x -> `HREF x) href; append (fun x -> `PORT x) port; append (fun x -> `TARGET x) target; append (fun x -> `TITLE x) title; append (fun x -> `TOOLTIP x) tooltip; append (fun x -> `VALIGN x) valign; append (fun x -> `WIDTH x) width; append (fun x -> `COLSPAN x) colspan; append (fun x -> `ROWSPAN x) rowspan; let font_attributes = ref [] in let append f x = append_to_ref font_attributes f x in append (fun x -> `COLOR x) fontcolor; append (fun x -> `FACE x) fontname; append (fun x -> `POINT_SIZE x) fontsize; (!attributes, f alpha !font_attributes) let cell_of_text = let f text = function | [] -> `html (`text text) | fattrs -> `html (`FONT (fattrs, `text text)) in cell_map f let cell_of_string = let f s = function | [] -> `html (`text [`string s]) | fattrs -> `html (`FONT (fattrs, `text [`string s])) in cell_map f let cell_of_table = let f table = function | [] -> `html (`TABLE table) | fattrs -> `html (`FONT (fattrs, `TABLE table)) in cell_map f let cell_of_html = let f html = function | [] -> `html html | fattrs -> `html (`FONT (fattrs, html)) in cell_map f let cell_of_label = let f label = let html = match label with | (`escaped s) -> (`text [`string s]) | (`html h) -> h in function | [] -> `html html | fattrs -> `html (`FONT (fattrs, html)) in cell_map f let cell_of_image ?align ?valign ?bgcolor ?border ?cellpadding ?cellspacing ?fixedsize ?height ?href ?port ?target ?title ?tooltip ?width ?colspan ?rowspan ?imagescale filename : cell = let attributes = ref [] in let append f x = append_to_ref attributes f x in append (fun x -> `ALIGN x) align; append (fun x -> `BGCOLOR x) bgcolor; append (fun x -> `BORDER x) border; append (fun x -> `CELLPADDING x) cellpadding; append (fun x -> `CELLSPACING x) cellspacing; append (fun x -> `FIXEDSIZE x) fixedsize; append (fun x -> `HEIGHT x) height; append (fun x -> `HREF x) href; append (fun x -> `PORT x) port; append (fun x -> `TARGET x) target; append (fun x -> `TITLE x) title; append (fun x -> `TOOLTIP x) tooltip; append (fun x -> `VALIGN x) valign; append (fun x -> `WIDTH x) width; append (fun x -> `COLSPAN x) colspan; append (fun x -> `ROWSPAN x) rowspan; let image_attributes = ref [] in let append f x = append_to_ref image_attributes f x in append (fun x -> `SCALE x) imagescale; append (fun x -> `SRC x) (Some filename); (!attributes, `IMG !image_attributes) let label_of_image ?align ?valign ?bgcolor ?border ?cellborder ?cellpadding ?cellspacing ?fixedsize ?height ?href ?port ?target ?title ?tooltip ?width ?imagescale filename = let cell = cell_of_image ?align ?valign ?bgcolor ?border ?cellpadding ?cellspacing ?fixedsize ?height ?href ?port ?target ?title ?tooltip ?width ?imagescale filename in let table = table ?border ?cellborder [[cell]] in `html (html_of_table table) end (* Html_like_constructors *) module Html_like_printer = struct (* let cat ?(tab="") = List.fold_left (fun s x -> Printf.sprintf "%s\n%s%s" s tab x) "" *) let cat ?(sep="\n") ?(tab="") = function | [] -> "" | y::ys -> List.fold_left (fun s x -> Printf.sprintf "%s%s%s%s" s sep tab x) y ys let string_of_color = Common.string_of_color let attribute tab = function | `ALIGN `CENTER -> Printf.sprintf "%sALIGN=\"%s\"" tab "CENTER" | `ALIGN `LEFT -> Printf.sprintf "%sALIGN=\"%s\"" tab "LEFT" | `ALIGN `RIGHT -> Printf.sprintf "%sALIGN=\"%s\"" tab "RIGHT" | `BGCOLOR color -> Printf.sprintf "%sBGCOLOR=\"%s\"" tab (string_of_color color) | `BORDER x -> Printf.sprintf "%sBORDER=\"%f\"" tab x | `CELLBORDER x -> Printf.sprintf "%sCELLBORDER=\"%f\"" tab x | `CELLPADDING x -> Printf.sprintf "%sCELLPADDING=\"%f\"" tab x | `CELLSPACING x -> Printf.sprintf "%sCELLSPACING=\"%f\"" tab x | `FIXEDSIZE b -> Printf.sprintf "%sFIXEDSIZE=\"%b\"" tab b | `HEIGHT x -> Printf.sprintf "%sHEIGHT=\"%f\"" tab x | `HREF s -> Printf.sprintf "%sHREF=\"%s\"" tab s | `PORT s -> Printf.sprintf "%sPORT=\"%s\"" tab s | `TARGET s -> Printf.sprintf "%sTARGET=\"%s\"" tab s | `TITLE s -> Printf.sprintf "%sTITLE=\"%s\"" tab s | `TOOLTIP s -> Printf.sprintf "%sTOOLTIP=\"%s\"" tab s | `VALIGN `MIDDLE -> Printf.sprintf "%sVALIGN=\"%s\"" tab "MIDDLE" | `VALIGN `BOTTOM -> Printf.sprintf "%sVALIGN=\"%s\"" tab "BOTTOM" | `VALIGN `TOP -> Printf.sprintf "%sVALIGN=\"%s\"" tab "TOP" | `WIDTH x -> Printf.sprintf "%sWIDTH=\"%f\"" tab x (* font *) | `COLOR color -> Printf.sprintf "%sCOLOR=\"%s\"" tab (string_of_color color) | `FACE s -> Printf.sprintf "%sFACE=\"%s\"" tab s | `POINT_SIZE i -> Printf.sprintf "%sPOINT-SIZE=\"%d\"" tab i (* cell *) | `COLSPAN i -> Printf.sprintf "%sCOLSPAN=\"%d\"" tab i | `ROWSPAN i -> Printf.sprintf "%sROWSPAN=\"%d\"" tab i (* image *) | `SCALE `FALSE -> Printf.sprintf "%sSCALE=\"%s\"" tab "FALSE" | `SCALE `TRUE -> Printf.sprintf "%sSCALE=\"%s\"" tab "TRUE" | `SCALE `WIDTH -> Printf.sprintf "%sSCALE=\"%s\"" tab "WIDTH" | `SCALE `HEIGHT -> Printf.sprintf "%sSCALE=\"%s\"" tab "HEIGHT" | `SCALE `BOTH -> Printf.sprintf "%sSCALE=\"%s\"" tab "BOTH" | `SRC s -> Printf.sprintf "%sSRC=\"%s\"" tab s let rec html_like tab = function | `text is -> text is | `TABLE tbl -> table tab tbl | `FONT html -> font tab html and string_or_br = function | `string s -> StringExtra.expand (function '>' -> Some ">" | '<' -> Some "<" | _ -> None ) s | `BR attribute_list -> let xs = List.map (attribute "") attribute_list in let br_and_attrs = cat ~sep:" " ("" br_and_attrs and text string_or_br_list = cat ~sep:"" (List.map string_or_br string_or_br_list) and table tab = let tab' = tab ^ " " in function | (attribute_list, row_list) -> let xs = List.map (attribute tab') attribute_list in let attrs = cat xs in let ys = List.map (row tab') row_list in let rows = cat ~tab:tab' ys in (* Printf.sprintf "%s\n%s\n%s" tab tab' attrs tab rows tab *) Printf.sprintf "\n%s\n%s\n%s
" tab attrs rows tab and row tab = let tab' = tab ^ " " in function cell_list -> let xs = List.map (cell tab') cell_list in let cells = cat ~tab:tab' xs in Printf.sprintf "%s\n%s\n%s" tab cells tab and cell_content tab = function | `html h -> html_like tab h (* In the case of an image, dot doesn't accept spaces among and !!!*) | `IMG img -> image img and cell tab = let tab' = tab ^ " " in function | (cell_attribute_list, html_or_image) -> let xs = List.map (attribute tab') cell_attribute_list in let attrs = cat ~tab:tab' xs in let content = cell_content tab' html_or_image in Printf.sprintf "%s%s" tab attrs content and font tab = let tab' = tab ^ " " in function | (attribute_list, content) -> let xs = List.map (attribute "") attribute_list in let attrs = cat ~sep:" " ~tab:"" xs in let content = html_like tab' content in Printf.sprintf "%s" attrs content and image attribute_list = let xs = List.map (attribute "") attribute_list in let attrs = cat xs in Printf.sprintf "" attrs end module String_of = struct let size = function | `force (x,y) -> Printf.sprintf "size=\"%f,%f!\"" x y | `max (x,y) -> Printf.sprintf "size=\"%f,%f\"" x y let page (x,y) = Printf.sprintf "page=\"%f,%f\"" x y let pagedir = function | `BL -> "pagedir=BL" | `BR -> "pagedir=BR" | `LB -> "pagedir=LB" | `LT -> "pagedir=LT" | `RB -> "pagedir=RB" | `RT -> "pagedir=RT" | `TL -> "pagedir=TL" | `TR -> "pagedir=TR" let rotate = Printf.sprintf "rotate=\"%f\"" let ratio = function | `auto -> "ratio=\"auto\"" | `compress -> "ratio=\"compress\"" | `fill -> "ratio=\"fill\"" | `float x -> Printf.sprintf "ratio=\"%f\"" x let margin (x,y) = Printf.sprintf "margin=\"%f,%f\"" x y let pos (x,y) = Printf.sprintf "pos=\"%f,%f\"" x y let center () = "center=\"1\"" let nodesep = Printf.sprintf "nodesep=\"%f\"" let ordering = function | `inp -> "ordering=\"in\"" | `out -> "ordering=\"out\"" let outputorder = function | `breadthfirst -> "outputorder=\"breadthfirst\"" | `edgesfirst -> "outputorder=\"edgesfirst\"" | `nodesfirst -> "outputorder=\"nodesfirst\"" let rank = function | `max -> "rank=\"max\"" | `min -> "rank=\"min\"" | `same -> "rank=\"same\"" | `sink -> "rank=\"sink\"" | `source -> "rank=\"source\"" let rankdir = function | `TB -> "rankdir=\"TB\"" | `BT -> "rankdir=\"BT\"" | `LR -> "rankdir=\"LR\"" | `RL -> "rankdir=\"RL\"" let ranksep = Printf.sprintf "ranksep=\"%f\"" let clusterrank = function | `global -> "clusterrank=\"global\"" | `local -> "clusterrank=\"local\"" | `none -> "clusterrank=\"none\"" let nslimit = Printf.sprintf "nslimit=\"%f\"" let layers xs = let ys = List.fold_left (fun s x -> s^":"^x) "" xs in Printf.sprintf "layers=\"%s\"" ys let string_of_color = Common.string_of_color let color x = Printf.sprintf "color=\"%s\"" (string_of_color x) let bgcolor x = Printf.sprintf "bgcolor=\"%s\"" (string_of_color x) let href = Printf.sprintf "href=\"%s\"" let url = Printf.sprintf "url=\"%s\"" let stylesheet = Printf.sprintf "stylesheet=\"%s\"" let charset = Printf.sprintf "charset=\"%s\"" let comment = Printf.sprintf "comment=\"%s\"" let compound () = "compound=\"true\"" let concentrate () = "concentrate=\"true\"" let regular () = "regular=\"true\"" let fontcolor x = Printf.sprintf "fontcolor=\"%s\"" (string_of_color x) let fillcolor x = Printf.sprintf "fillcolor=\"%s\"" (string_of_color x) let pencolor x = Printf.sprintf "pencolor=\"%s\"" (string_of_color x) let labelfontcolor x = Printf.sprintf "labelfontcolor=\"%s\"" (string_of_color x) let fontname = Printf.sprintf "fontname=\"%s\"" let labelfontname = Printf.sprintf "labelfontname=\"%s\"" let fontpath xs = let ys = List.fold_left (fun s x -> s^":"^x) "" xs in Printf.sprintf "fontpath=\"%s\"" ys let fontsize = Printf.sprintf "fontsize=\"%d\"" let labelfontsize = Printf.sprintf "labelfontsize=\"%d\"" let string_of_html_like (html :html_like) = Html_like_printer.html_like "" html let gen_label label = function | `escaped x -> Printf.sprintf "%s=\"%s\"" label x | `html h -> Printf.sprintf "%s=<%s>" label (string_of_html_like h) let label = gen_label "label" let headlabel = gen_label "headlabel" let taillabel = gen_label "taillabel" let labeljust = function | `c -> "labeljust=\"c\"" | `l -> "labeljust=\"l\"" | `r -> "labeljust=\"r\"" let labelloc = function | `b -> "labelloc=\"b\"" | `t -> "labelloc=\"t\"" let nojustify () = "nojustify=\"true\"" let fixedsize () = "fixedsize=\"true\"" let constraint_off () = "constraint=\"false\"" let decorate () = "decorate=\"true\"" let labelfloat () = "labelfloat=\"true\"" let peripheries = Printf.sprintf "peripheries=\"%d\"" let quantum = Printf.sprintf "quantum=\"%f\"" let remincross () = "remincross=\"true\"" let samplepoints = Printf.sprintf "samplepoints=\"%d\"" let distortion = Printf.sprintf "distortion=\"%f\"" let group = Printf.sprintf "group=\"%s\"" let height = Printf.sprintf "height=\"%f\"" let orientation = Printf.sprintf "orientation=\"%f\"" let width = Printf.sprintf "width=\"%f\"" let headclip = Printf.sprintf "headclip=\"%b\"" let tailclip = Printf.sprintf "tailclip=\"%b\"" let string_of_style = function | `bold -> "bold" | `dashed -> "dashed" | `diagonals -> "diagonals" | `dotted -> "dotted" | `filled -> "filled" | `invis -> "invis" | `rounded -> "rounded" | `solid -> "solid" let style xs = let ys = List.map string_of_style xs in let zs = List.fold_left (fun s x -> s^","^x) "" ys in Printf.sprintf "style=\"%s\"" zs let layer xs = let ys = List.fold_left (fun s x -> s^":"^x) "" xs in Printf.sprintf "layer=\"%s\"" ys let string_of_shape = function | `Mcircle -> "Mcircle" | `Mdiamond -> "Mdiamond" | `Msquare -> "Msquare" | `box -> "box" | `circle -> "circle" | `diamond -> "diamond" | `doublecircle -> "doublecircle" | `doubleoctagon -> "doubleoctagon" | `egg -> "egg" | `ellipse -> "ellipse" | `hexagon -> "hexagon" | `house -> "house" | `invhouse -> "invhouse" | `invtrapezium -> "invtrapezium" | `invtriangle -> "invtriangle" | `none -> "none" | `octagon -> "octagon" | `parallelogram -> "parallelogram" | `pentagon -> "pentagon" | `plaintext -> "plaintext" | `point -> "point" | `rect -> "rect" | `rectangle -> "rectangle" | `septagon -> "septagon" | `trapezium -> "trapezium" | `triangle -> "triangle" | `tripleoctagon -> "tripleoctagon" (* Managed outside: *) | `polygon (sides,skew) -> assert false | `epsf filename -> assert false let shape = function | `polygon (sides,skew) -> Printf.sprintf "shape=\"polygon\", sides=\"%d\", skew=\"%d\"" sides skew | `epsf filename -> Printf.sprintf "shape=\"epsf\", shapefile=\"%s\"" filename | x -> Printf.sprintf "shape=\"%s\"" (string_of_shape x) (* For node (dot-undocumented) option "image=filename" *) let image = Printf.sprintf "image=\"%s\"" let string_of_arrow_type = function | `Open -> "open" | `box -> "box" | `crow -> "crow" | `diamond -> "diamond" | `dot -> "dot" | `ediamond -> "ediamond" | `empty -> "empty" | `halfopen -> "halfopen" | `inv -> "inv" | `invdot -> "invdot" | `invempty -> "invempty" | `invodot -> "invodot" | `none -> "none" | `normal -> "normal" | `obox -> "obox" | `odiamond -> "odiamond" | `odot -> "odot" | `tee -> "tee" | `vee -> "vee" let arrowhead x = Printf.sprintf "arrowhead=\"%s\"" (string_of_arrow_type x) let arrowtail x = Printf.sprintf "arrowtail=\"%s\"" (string_of_arrow_type x) let string_of_dir= function | `back -> "back" | `both -> "both" | `forward -> "forward" | `none -> "none" let dir x = Printf.sprintf "dir=\"%s\"" (string_of_dir x) let arrowsize = Printf.sprintf "arrowsize=\"%f\"" let labelangle = Printf.sprintf "labelangle=\"%f\"" let labeldistance = Printf.sprintf "labeldistance=\"%f\"" let string_of_compass_point = function | `e -> "e" | `n -> "n" | `ne -> "ne" | `nw -> "nw" | `s -> "s" | `se -> "se" | `sw -> "sw" | `w -> "w" let head_or_tail_port label = function | ident, None -> Printf.sprintf "%s=\"%s\"" label ident | ident, (Some cp) -> Printf.sprintf "%s=\"%s:%s\"" label ident (string_of_compass_point cp) let headport = head_or_tail_port "headport" let tailport = head_or_tail_port "tailport" let lhead = Printf.sprintf "lhead=\"%s\"" let ltail = Printf.sprintf "ltail=\"%s\"" let minlen = Printf.sprintf "minlen=\"%d\"" let samehead = Printf.sprintf "samehead=\"%s\"" let sametail = Printf.sprintf "sametail=\"%s\"" let weight = Printf.sprintf "weight=\"%f\"" let z = Printf.sprintf "z=\"%f\"" end let append options injection conv opt = match opt with | None -> () | Some x -> (options := (injection (conv x))::!options) module Extract = struct let unit = function None -> false | Some () -> true let bool ?(default=false) = function None -> default | Some b -> b let ident ?(prefix="id") = let counter = ref 0 in function | None -> let result = Printf.sprintf "%s%d" prefix !counter in ((incr counter); result) | Some id -> id end (* Extract *) let map_graph_options f ?strict ?digraph ?name ?size ?page ?pagedir ?rotate ?ratio ?margin ?center ?nodesep ?ordering ?outputorder ?rank ?rankdir ?ranksep ?clusterrank ?nslimit ?layers ?color ?bgcolor ?href ?url ?stylesheet ?charset ?comment ?compound ?concentrate ?fontcolor ?fontname ?fontpath ?fontsize ?label ?labeljust ?labelloc ?nojustify ?quantum ?remincross ?samplepoints statement_list = let strict = Extract.unit strict in let digraph = Extract.bool ~default:true digraph in let name = Extract.ident ~prefix:"graph_" name in (** Create the container of options: *) let graph_options = ref [] in let append f x = append graph_options (fun e-> Graph_default e) f x in append (String_of.size) size; append (String_of.page) page; append (String_of.pagedir) pagedir; append (String_of.rotate) rotate; append (String_of.ratio) ratio; append (String_of.margin) margin; append (String_of.center) center; append (String_of.nodesep) nodesep; append (String_of.ordering) ordering; append (String_of.outputorder) outputorder; append (String_of.rank) rank; append (String_of.rankdir) rankdir; append (String_of.ranksep) ranksep; append (String_of.clusterrank) clusterrank; append (String_of.nslimit) nslimit; append (String_of.layers) layers; append (String_of.color) color; append (String_of.bgcolor) bgcolor; append (String_of.href) href; append (String_of.url) url; append (String_of.stylesheet) stylesheet; append (String_of.charset) charset; append (String_of.comment) comment; append (String_of.compound) compound; append (String_of.concentrate) concentrate; append (String_of.fontcolor) fontcolor; append (String_of.fontname) fontname; append (String_of.fontpath) fontpath; append (String_of.fontsize) fontsize; append (String_of.label) label; append (String_of.labeljust) labeljust; append (String_of.labelloc) labelloc; append (String_of.nojustify) nojustify; append (String_of.quantum) quantum; append (String_of.remincross) remincross; append (String_of.samplepoints) samplepoints; f strict digraph name statement_list graph_options let graph = let f strict digraph name statement_list graph_options = { strict = strict; digraph = digraph; name=name; statements = List.append !graph_options statement_list; } in map_graph_options f let graph_default = let map_graph_options_call = let f strict digraph name statement_list graph_options = Graph_defaults (List.map (function Graph_default x -> x | _ -> assert false) !graph_options) in map_graph_options f in map_graph_options_call ?strict:None ?digraph:None ?name:None let subgraph ?name ?rank statement_list = let name = Extract.ident ~prefix:"subgraph_" name in let statements = ref statement_list in let append f x = append statements (fun e-> Graph_default e) f x in append (String_of.rank) rank; Subgraph (name, !statements) let cluster ?name_suffix ?rank ?color ?bgcolor ?fillcolor ?pencolor ?fontcolor ?fontname ?fontsize ?label ?labeljust ?labelloc ?nojustify ?url ?peripheries ?style statement_list = let name = "cluster_"^(Extract.ident name_suffix) in let statements = ref statement_list in let append f x = append statements (fun e-> Graph_default e) f x in append (String_of.rank) rank; append (String_of.color) color; append (String_of.bgcolor) bgcolor; append (String_of.fillcolor) fillcolor; append (String_of.pencolor) pencolor; append (String_of.fontcolor) fontcolor; append (String_of.fontname) fontname; append (String_of.fontsize) fontsize; append (String_of.label) label; append (String_of.labeljust) labeljust; append (String_of.labelloc) labelloc; append (String_of.nojustify) nojustify; append (String_of.url) url; append (String_of.peripheries) peripheries; append (String_of.style) style; Subgraph (name, !statements) let map_edge_options f ?url ?color ?comment ?arrowhead ?arrowtail ?dir ?arrowsize ?constraint_off ?decorate ?fontcolor ?fontname ?fontsize ?headclip ?headlabel ?headport ?tailclip ?taillabel ?tailport ?label ?labelangle ?labeldistance ?labelfloat ?labelfontcolor ?labelfontname ?labelfontsize ?layer ?lhead ?ltail ?minlen ?nojustify ?pos ?samehead ?sametail ?style ?weight alpha = let edge_options = ref [] in let append f x = append edge_options (fun e->e) f x in append (String_of.url) url; append (String_of.color) color; append (String_of.comment) comment; append (String_of.arrowhead) arrowhead; append (String_of.arrowtail) arrowtail; append (String_of.dir) dir; append (String_of.arrowsize) arrowsize; append (String_of.constraint_off) constraint_off; append (String_of.decorate) decorate; append (String_of.fontcolor) fontcolor; append (String_of.fontname) fontname; append (String_of.fontsize) fontsize; append (String_of.headclip) headclip; append (String_of.headlabel) headlabel; append (String_of.headport) headport; append (String_of.tailclip) tailclip; append (String_of.taillabel) taillabel; append (String_of.tailport) tailport; append (String_of.label) label; append (String_of.labelangle) labelangle; append (String_of.labeldistance) labeldistance; append (String_of.labelfloat) labelfloat; append (String_of.labelfontcolor) labelfontcolor; append (String_of.labelfontname) labelfontname; append (String_of.labelfontsize) labelfontsize; append (String_of.layer) layer; append (String_of.lhead) lhead; append (String_of.ltail) ltail; append (String_of.minlen) minlen; append (String_of.nojustify) nojustify; append (String_of.pos) pos; append (String_of.samehead) samehead; append (String_of.sametail) sametail; append (String_of.style) style; append (String_of.weight) weight; f alpha edge_options let edge = let f = fun node_ident_head edge_options node_ident_tail -> Edge (node_ident_head, node_ident_tail, !edge_options) in map_edge_options f let edge_default = let f _ edge_options = (Edge_defaults !edge_options) in map_edge_options f let map_node_options f ?url ?color ?comment ?distortion ?fillcolor ?fontcolor ?fontname ?fontsize ?fixedsize ?group ?height ?layer ?margin ?nojustify ?orientation ?peripheries ?pos ?regular ?shape ?image ?label ?style ?width ?z node_ident = let node_options = ref [] in let append f x = append node_options (fun e->e) f x in append (String_of.url) url; append (String_of.color) color; append (String_of.comment) comment; append (String_of.distortion) distortion; append (String_of.fillcolor) fillcolor; append (String_of.fontcolor) fontcolor; append (String_of.fontname) fontname; append (String_of.fontsize) fontsize; append (String_of.fixedsize) fixedsize; append (String_of.group) group; append (String_of.height) height; append (String_of.layer) layer; append (String_of.margin) margin; append (String_of.nojustify) nojustify; append (String_of.orientation) orientation; append (String_of.peripheries) peripheries; append (String_of.pos) pos; append (String_of.regular) regular; append (String_of.shape) shape; append (String_of.image) image; append (String_of.label) label; append (String_of.style) style; append (String_of.width) width; append (String_of.z) z; f node_ident node_options let node = let f = fun node_ident node_options -> Node (node_ident, !node_options) in map_node_options f let node_default = let f _ node_options = (Node_defaults !node_options) in map_node_options f let phantom_fresh_name = Counter.make_string_generator ~prefix:"_phantom_" () (* shorthand *) module Html = Html_like_constructors (* Node redefinition, in order to manage the pseudo-option "outlabel" *) let node ?url ?color ?comment ?distortion ?fillcolor ?fontcolor ?fontname ?fontsize ?fixedsize ?group ?height ?layer ?margin ?nojustify ?orientation ?peripheries ?pos ?regular ?shape ?image ?label ?style ?width ?z ?outlabel node_ident = let super = node in (* The redefined function *) match outlabel with | None -> super ?url ?color ?comment ?distortion ?fillcolor ?fontcolor ?fontname ?fontsize ?fixedsize ?group ?height ?layer ?margin ?nojustify ?orientation ?peripheries ?pos ?regular ?shape ?image ?label ?style ?width ?z node_ident | Some outlabel -> let wrapped_label = (match label with | None -> (`escaped node_ident) | Some label -> label ) in let label = let table_content = match outlabel with | `north label -> let l = Html.cell_of_label ~valign:`BOTTOM label in let n = Html.cell_of_label ~valign:`TOP wrapped_label in [[l];[n]] | `south label -> let l = Html.cell_of_label ~valign:`TOP label in let n = Html.cell_of_label ~valign:`BOTTOM wrapped_label in [[n];[l]] | `east label -> let l = Html.cell_of_label ~align:`LEFT label in let n = Html.cell_of_label ~align:`RIGHT wrapped_label in [[n;l]] | `west label -> let l = Html.cell_of_label ~align:`RIGHT label in let n = Html.cell_of_label ~align:`LEFT wrapped_label in [[l;n]] in Html.label_of_table (Html.table ~align:`CENTER ~border:0. ~cellborder:0. ~cellspacing:0. table_content) in super ?url ?color ?comment ?distortion ?fillcolor ?fontcolor ?fontname ?fontsize ?fixedsize ?group ?height ?layer ?margin ?nojustify ?orientation ?peripheries ?pos ?regular ?shape ?image ~label ?style ?width ?z node_ident let graph_of_list nns = let sl = List.map (function (n1,n2) -> edge n1 n2) nns in graph sl include Html_like_constructors let working_output_formats ?no_file_inspection () = let g = (graph [node "good_luck"]) in let dotfile = Filename.temp_file "Dot.make_image." ".dot" in let imgfile = Filename.temp_file "Dot.make_image." ".img" in let mill imgtype = try let _ = make_image ~silent:() ~imgtype ~dotfile ~imgfile g in let file_output = match no_file_inspection with | Some () -> "" | None -> let cmd = Printf.sprintf "file -b -z %s" imgfile in StringExtra.rstrip (UnixExtra.shell cmd) in Some (imgtype, (string_of_output_format imgtype), (output_format_description imgtype), file_output) with _ -> None in let result = ListExtra.filter_map mill admissible_output_formats in let () = List.iter Unix.unlink [dotfile; imgfile] in result (** Redefined with a cache: *) let working_output_formats = let cache1 = ref None in let cache2 = ref None in fun ?no_file_inspection () -> let run_with_cache cache = match !cache with | None -> let result = working_output_formats ?no_file_inspection () in cache := Some result; result | Some result -> result in match no_file_inspection with | None -> run_with_cache cache1 | Some () -> run_with_cache cache2 let working_output_formats_as_objects ?no_file_inspection () = List.map (fun (x,y,z,t) -> object method output_format = x method output_format_as_string = y method description = z method file_command_output = t end) (working_output_formats ?no_file_inspection ()) ocamlbricks-0.90+bzr456.orig/Makefile0000644000175000017500000010674613175721005016401 0ustar lucaslucas# This -*- makefile -*- is part of our build system for OCaml projects # Copyright (C) 2008, 2009 Luca Saiu # Copyright (C) 2008, 2010, 2016 Jean-Vincent Loddo # Copyright (C) 2008, 2009, 2010, 2016 Université Paris 13 # Updated in 2008 by Jonathan Roudiere # Thanks to JulioJu (https://github.com/JulioJu) for the patch # about prefix_install # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # This is the revision of 2016-06-07. ###################################################################### # This make file is general-purpose: the actual project-dependant part # should be written for each specific project in a 'Makefile.local' # file. # # This contains some (simple) makefile magic which is only supported # by GNU Make. Don't even try to use other make implementations. ###################################################################### ###################################################################### # Implementation of targets. Note that the user is *not* supposed to # override these, but only to define the project-dependant '-local' # versions: # Makefiles (this one as those in other parts) use extensively the bash shell SHELL=/bin/bash OCAMLBUILD = $$( $(call OCAMLBUILD_COMMAND_LINE) ) LIBRARYPREFIX=$(shell $(call READ_CONFIG, libraryprefix); echo $$libraryprefix) OCAML_VERSION=$(shell $(call READ_CONFIG, ocaml_version); echo $$ocaml_version) OCAML_LIBRARYPREFIX=$(shell $(call READ_CONFIG, ocaml_libraryprefix); echo $$ocaml_libraryprefix) # The main target. Its implementation is entirely project-dependant: main: ocamlbuild-stuff manually_pre_actions main-local data libraries programs manually_post_actions @(echo "Success.") # Build C modules (no one, by default): c-modules: @(mkdir _build &> /dev/null || true) && \ for x in $(C_OBJECTS_TO_LINK); do \ make _build/$$x.o; \ done BUILD_FROM_STUFF = \ @( echo "Building $(1)..."; \ shopt -s execfail; set -e; \ for x in $(2); do \ echo "Building \"$$x\"..."; \ if $(MAKE) $$x; then \ echo "Ok, \"$$x\" was built with success."; \ else \ echo "FAILED when building \"$$x\"."; \ exit -1; \ fi; \ done; \ echo "Success: $(1) were built.") # Build only data: data: ocamlbuild-stuff data-local $(DATA) $(call BUILD_FROM_STUFF, data, $(DATA)) # Build only native libraries: native-libraries: ocamlbuild-stuff c-modules native-libraries-local $(NATIVE_LIBRARIES) $(call BUILD_FROM_STUFF, native-libraries, $(NATIVE_LIBRARIES)) # Build only bytecode libraries: byte-libraries: ocamlbuild-stuff c-modules byte-libraries-local $(BYTE_LIBRARIES) $(call BUILD_FROM_STUFF, byte-libraries, $(BYTE_LIBRARIES)) # Build libraries; bytecode, native, or both: libraries: c-modules libraries-local @($(call BUILD_NATIVE_ANDOR_BYTECODE,libraries) ) # Spaces are ok # Build programs; bytecode, native, or both: programs: c-modules programs-local @($(call BUILD_NATIVE_ANDOR_BYTECODE,programs) ) # Spaces are ok # Build the native and/or bytecode version of $(1). $(1) may be either # "libraries" or "programs". *Don't* put a space before the argument. BUILD_NATIVE_ANDOR_BYTECODE = \ (if [ "$$( $(call NATIVE) )" == 'native' ]; then \ echo "Building native $(1)..."; \ if $(MAKE) native-$(1); then \ echo "Success: native $(1) were built."; \ else \ echo "FAILURE: could not build native $(1)."; \ exit -1; \ fi; \ else \ echo "NOT building native $(1)..."; \ fi; \ if [ "$$( $(call BYTE) )" == 'byte' ]; then \ echo "Builing bytecode $(1)..."; \ if $(MAKE) byte-$(1); then \ echo "Success: bytecode $(1) were built."; \ else \ echo "FAILURE: could not build bytecode $(1)."; \ exit -1; \ fi; \ else \ echo "NOT building bytecode $(1)..."; \ fi) # Build only native programs: native-programs: ocamlbuild-stuff native-programs-local $(NATIVE_PROGRAMS) $(ROOT_NATIVE_PROGRAMS) $(call BUILD_FROM_STUFF, native-programs, $(NATIVE_PROGRAMS) $(ROOT_NATIVE_PROGRAMS)) # Build only bytecode programs: byte-programs: ocamlbuild-stuff byte-programs-local $(BYTE_PROGRAMS) $(ROOT_BYTE_PROGRAMS) $(call BUILD_FROM_STUFF, byte-programs, $(BYTE_PROGRAMS) $(ROOT_BYTE_PROGRAMS)) # 'all' is just an alias for 'main': all: main # In some projects we may need to build something more than 'main', # but we do nothing more by default: world: world-local main @(echo 'Success.') ############################################################################ # Support for manually generated files (i.e. not generated with ocamlbuild) ############################################################################ # Example: (in your Makefile.local) # # foo.byte : manually_pre_actions # foo.native : manually_pre_actions # # MANUALLY_PRE_COPY_IN_build = include_as_string_p4.ml USAGE.txt # MANUALLY_PRE_MAKE_IN_build = include_as_string_p4.cmo # # _build/include_as_string_p4.cmo: include_as_string_p4.ml # ocamlc -c -I +camlp4 camlp4lib.cma -pp camlp4of -o $@ $< .PHONY : manually_pre_actions manually_post_actions ################################# PRE-ACTIONS support # Files that must be copied in _build/ *before* the ocamlbuild processing. MANUALLY_PRE_COPY_IN_build = # Targets that must be created in _build/ *before* the ocamlbuild processing. # For each foo.bar that appears in this list, you have to write a rule # _build/foo.bar in your Makefile.local MANUALLY_PRE_MAKE_IN_build = manually_pre_actions: $(call PERFORM_MANUALLY_PRE_ACTIONS, $(MANUALLY_PRE_COPY_IN_build),$(MANUALLY_PRE_MAKE_IN_build)) # Detect if "make clean" is required or copy and build manually targets # specified in MANUALLY_PRE_COPY_IN_build and MANUALLY_PRE_MAKE_IN_build PERFORM_MANUALLY_PRE_ACTIONS = \ @(\ if test -d _build/; \ then \ echo "Checking if files manually copied in _build/ have been modified..."; \ for x in $(1); do \ echo "Checking \"$$x\"..."; \ test ! -f _build/$$x || \ diff -q $$x _build/$$x 2>/dev/null || \ { echo -e "********************\nmake clean required!\n********************"; exit 1; } ;\ done; \ else \ mkdir _build/; \ fi; \ for x in $(1); do echo "Manually pre-copying \"$$x\"..."; cp --parent -f $$x _build/; done; \ for y in $(2); do echo "Manually pre-building \"$$y\"..."; make _build/$$y || exit 1; done; \ ) ################################# POST-ACTIONS support # Files that must be copied in _build/ *after* the ocamlbuild processing. MANUALLY_POST_COPY_IN_build = # Targets that must be created in _build/ *after* the ocamlbuild processing. # For each foo.bar that appears in this list, you have to write a rule # _build/foo.bar in your Makefile.local MANUALLY_POST_MAKE_IN_build = manually_post_actions: $(call PERFORM_MANUALLY_POST_ACTIONS, $(MANUALLY_POST_COPY_IN_build), $(MANUALLY_POST_MAKE_IN_build)) PERFORM_MANUALLY_POST_ACTIONS = \ @(\ for x in $(1); do echo "Manually post-copying \"$$x\"..."; cp --parent -f $$x _build/; done; \ for y in $(2); do echo "Manually post-building \"$$y\"..."; make _build/$$y || exit 1; done; \ ) ############################################################################ # Other entries # Edit all ml/mli files and Makefile.local with your $EDITOR edit: test -n "$$EDITOR" && eval $$EDITOR Makefile.local $$(find . \( -name "_build*" -o -name "meta.ml" -o -name "$(EXCLUDE_FROM_EDITING)" -o -name "version.ml" -o -name "gui.ml" -o -name myocamlbuild.ml \) -prune -o -type f -a \( -name "*.ml" -o -name "*.mli" \) -print) & # Create the documentation documentation: world documentation-local chmod +x Makefile.d/doc.sh Makefile.d/doc.sh -pp "$(PP_OPTION)" -e "$(UNDOCUMENTED)" -i $(DIRECTORIES_TO_INCLUDE) doc: documentation INDEX_HTML=_build/doc/html/index.html browse: test -f $(INDEX_HTML) || make documentation test -n "$$BROWSER" && $$BROWSER $(INDEX_HTML) # Install programs and libraries: install: install-programs install-libraries install-data install-configuration install-documentation install-local @(echo 'Success.') # The user is free to override this to add custom targets to install into the # $prefix_install/share/$name installation directory: OTHER_DATA_TO_INSTALL = # The user is free to override this to add custom targets to install into the # $documentationprefix/$name installation directory: OTHER_DOCUMENTATION_TO_INSTALL = # Install the documentation from this package (_build/doc) into $prefix_install/share/$name: install-documentation: META CONFIGME install-documentation-local @($(call READ_CONFIG, documentationprefix); \ $(call READ_META, name); \ directory=$$documentationprefix/$$name; \ shopt -s nullglob; \ if [ -e _build/doc ]; then \ documentationifany=`ls -d _build/doc/*`; \ else \ documentationifany=''; \ fi; \ if [ "$$documentationifany" == "" ]; then \ echo "No documentation to install: ok, no problem..."; \ else \ echo "Installing $$name documentation into $$directory ..."; \ echo "Creating $$directory ..."; \ if mkdir -p $$directory; then \ echo "The directory $$directory was created with success."; \ else \ echo "Could not create $$directory"; \ exit -1; \ fi; \ echo "Copying $$name documentation to $$directory ..."; \ for x in COPYING README $$documentationifany $(OTHER_DOCUMENTATION_TO_INSTALL); do \ if cp -af $$x $$directory; then \ echo "Installed $$x into $$directory/"; \ else \ echo "Could not write $$directory/$$x."; \ exit -1; \ fi; \ done; \ echo "Documentation installation for $$name was successful."; \ fi) # Just a handy alias: install-doc: install-documentation # Install the data from this package into $prefix_install/share/$name: install-data: META CONFIGME main install-data-local @($(call READ_CONFIG, prefix_install); \ $(call READ_META, name); \ directory=$$prefix_install/share/$$name; \ shopt -s nullglob; \ if [ -e share ]; then \ dataifany=`ls -d share/*`; \ else \ dataifany=''; \ fi; \ if [ "$$dataifany" == "" ]; then \ echo "No data to install: ok, no problem..."; \ else \ echo "Installing $$name data into $$directory ..."; \ echo "Creating $$directory ..."; \ if mkdir -p $$directory; then \ echo "The directory $$directory was created with success."; \ else \ echo "Could not create $$directory"; \ exit -1; \ fi; \ echo "Copying $$name data to $$directory ..."; \ for x in COPYING README $$dataifany $(OTHER_DATA_TO_INSTALL); do \ if cp -af $$x $$directory; then \ echo "Installed $$x into $$directory/"; \ else \ echo "Could not write $$directory/$$x."; \ exit -1; \ fi; \ done; \ echo "Data installation for $$name was successful."; \ fi) # Install the software configuration files, if any: install-configuration: META CONFIGME install-configuration-local @($(call READ_CONFIG, configurationprefix); \ $(call READ_META, name); \ if [ -e etc ]; then \ echo "Installing configuration files into $$configurationprefix/$$name..."; \ mkdir -p $$configurationprefix/$$name; \ shopt -s nullglob; \ for file in etc/*; do \ basename=`basename $$file`; \ echo "Installing $$basename into $$configurationprefix/$$name..."; \ if ! cp $$file $$configurationprefix/$$name/; then \ echo "ERROR: Could not install $$basename into $$configurationprefix/$$name"; \ exit -1; \ fi; \ done; \ else \ echo "We don't have any configuration files to install."; \ fi) # Uninstall the software configuration files, if any: uninstall-configuration: CONFIGME uninstall-configuration-local @($(call READ_CONFIG, configurationprefix); \ if [ -e etc ]; then \ echo "Removing configuration files from $$configurationprefix..."; \ shopt -s nullglob; \ for file in etc/*; do \ basename=`basename $$file`; \ echo "Uninstalling $$basename from $$configurationprefix..."; \ if ! rm -f $$configurationprefix/$$basename; then \ echo "ERROR: Could not remove $$basename from $$configurationprefix"; \ exit -1; \ fi; \ done; \ else \ echo "We don't have any configuration files to remove."; \ fi) # Remove the data of this package from $prefix_install/share/$name: uninstall-data: META CONFIGME uninstall-data-local @( ($(call READ_CONFIG, prefix_install); \ $(call READ_META, name); \ directory=$$prefix_install/share/$$name; \ echo "Removing $$name data from $$prefix_install/share/..."; \ shopt -s nullglob; \ if rm -rf $$directory; then \ echo "The entire directory $$directory was removed."; \ else \ echo "Could not delete $$directory"; \ exit -1; \ fi); \ echo 'Data uninstallation was successful.') # Remove the documentation of this package from $documentationprefix/$name: uninstall-documentation: META CONFIGME uninstall-documentation-local @( ($(call READ_CONFIG, documentationprefix); \ $(call READ_META, name); \ directory=$$documentationprefix/$$name; \ echo "Removing $$name documentation from $$documentationprefix..."; \ shopt -s nullglob; \ if rm -rf $$directory; then \ echo "The entire directory $$directory was removed."; \ else \ echo "Could not delete $$directory"; \ exit -1; \ fi); \ echo 'Documentation uninstallation was successful.') # The user is free to override this to add custom targets to install into the # $prefix_install/bin installation directory; the typical use of this would be # installing scripts. OTHER_PROGRAMS_TO_INSTALL = # These are programs to be installed into $prefix_install/sbin # instead of $prefix_install/bin: ROOT_NATIVE_PROGRAMS = ROOT_BYTE_PROGRAMS = # Install the programs from this package into $prefix_install/bin: install-programs: META CONFIGME programs install-programs-local @($(call READ_CONFIG, prefix_install); \ $(call READ_META, name); \ echo "Creating $$prefix_install/bin/..."; \ (mkdir -p $$prefix_install/bin &> /dev/null || true); \ echo "Creating $$prefix_install/sbin/..."; \ (mkdir -p $$prefix_install/sbin &> /dev/null || true); \ echo "Installing programs from $$name into $$prefix_install/bin/..."; \ shopt -s nullglob; \ for file in $(OTHER_PROGRAMS_TO_INSTALL) _build/*.byte _build/*.native; do \ basename=`basename $$file`; \ if echo " $(ROOT_NATIVE_PROGRAMS) $(ROOT_BYTE_PROGRAMS) " | grep -q " $$basename "; then \ echo "Installing "`basename $$file`" as a \"root program\" into $$prefix_install/sbin..."; \ cp -a $$file $$prefix_install/sbin/; \ chmod +x $$prefix_install/sbin/$$basename; \ else \ echo "Installing "`basename $$file`" into $$prefix_install/bin..."; \ cp -a $$file $$prefix_install/bin/; \ chmod +x $$prefix_install/bin/$$basename; \ fi; \ done) && \ echo 'Program installation was successful.' # Remove the programs from this package from $prefix_install/bin: uninstall-programs: META CONFIGME main uninstall-programs-local @($(call READ_CONFIG, prefix_install); \ $(call READ_META, name); \ echo "Removing $$name programs..."; \ shopt -s nullglob; \ for file in $(OTHER_PROGRAMS_TO_INSTALL) _build/*.byte _build/*.native; do \ basename=`basename $$file`; \ if echo " $(ROOT_NATIVE_PROGRAMS) $(ROOT_BYTE_PROGRAMS) " | grep -q " $$basename "; then \ echo -e "Removing the \"root program\" $$basename from $$prefix_install/sbin..."; \ export pathname=$$prefix_install/sbin/`basename $$file`; \ else \ echo -e "Removing $$basename from $$prefix_install/bin..."; \ export pathname=$$prefix_install/bin/`basename $$file`; \ fi; \ rm -f $$pathname; \ done) && \ echo 'Program uninstallation was successful.' # The user is free to override this to add custom targets to install into the # library installation directory: OTHER_LIBRARY_FILES_TO_INSTALL = # Install the library in this package into the path chosen at configuration time: install-libraries: libraries install-libraries-local @($(call READ_META,name); \ if [ "$(NATIVE_LIBRARIES) $(BYTE_LIBRARIES)" == " " ]; then \ echo "There are no native libraries to install: ok, no problem..."; \ else \ (echo "Installing $$name libraries into "$(LIBRARYPREFIX)"/$$name/..."; \ (mkdir -p $(LIBRARYPREFIX)/$$name &> /dev/null || true); \ shopt -s nullglob; \ cp -f META $(OTHER_LIBRARY_FILES_TO_INSTALL) \ _build/*.cma _build/*.cmxa _build/*.a _build/*.so \ `find _build/ -name \*.cm\[iox\] | grep -v /myocamlbuild` \ `find _build/ -name \*.mli | grep -v /myocamlbuild` \ $(LIBRARYPREFIX)/$$name/) && \ if test -d $(LIBRARYPREFIX)/stublibs/; then \ find _build/ -name "dll*.so" -exec cp -f "{}" $(LIBRARYPREFIX)/stublibs/ ";" ; \ fi; \ echo 'Library installation was successful.'; \ fi) # Uninstall programs and libraries: uninstall: uninstall-programs uninstall-libraries uninstall-data uninstall-configuration uninstall-documentation uninstall-local @(echo 'Success.') # Remove the library from the installation path chosen at configuration time: uninstall-libraries: main uninstall-libraries-local @(($(call READ_META,name); \ echo "Uninstalling $$name libraries from "$(LIBRARYPREFIX)" ..."; \ shopt -s nullglob; \ rm -rf $(LIBRARYPREFIX)/$$name/) && \ echo 'Library uninstallation was successful.') # Make a source tarball: dist: clean dist-local @($(call READ_META, name, version); \ $(call FIX_VERSION); \ echo "Making the source tarball _build/$$name-$$version.tar.gz ..."; \ if [ -d .bzr ]; then \ $(MAKE) meta.ml.released; \ $(MAKE) ChangeLog; \ fi; \ mkdir -p _build/$$name-$$version; \ cp -af * _build/$$name-$$version/ &> /dev/null; \ (tar --exclude=_build --exclude=meta.ml --exclude=.bzr -C _build -czf \ _build/$$name-$$version.tar.gz $$name-$$version/ && \ rm -rf _build/$$name-$$version)) && \ if [ -d .bzr ]; then \ rm -f meta.ml.released ChangeLog; \ fi; \ echo "Success." # These files are included also in binary tarballs: FILES_TO_ALWAYS_DISTRIBUTE = \ COPYING README INSTALL AUTHORS THANKS META Makefile Makefile.local CONFIGME \ REQUIREMENTS NEWS ChangeLog # Make a binary tarball: dist-binary: dist-binary-local main documentation @(($(call READ_META, name, version); \ $(call FIX_VERSION); \ architecture=$$(echo `uname -o`-`uname -m` | sed 's/\//-/g'); \ directoryname=$$name-$$version--binary-only--$$architecture; \ filename=$$directoryname.tar.gz; \ echo "Making the binary tarball _build/$$filename ..."; \ $(MAKE) ChangeLog; \ mkdir -p _build/$$directoryname; \ mkdir -p _build/$$directoryname/_build; \ shopt -s nullglob; \ for x in $(FILES_TO_ALWAYS_DISTRIBUTE) share doc etc; do \ cp $$x _build/$$directoryname &> /dev/null; \ done; \ for x in $(NATIVE_PROGRAMS) $(NATIVE_LIBRARIES) $(BYTE_PROGRAMS) $(BYTE_LIBRARIES); do \ cp _build/$$x _build/$$directoryname/_build; \ done; \ for x in `find _build/ -name \*.cmi | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ `find _build/ -name \*.mli | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ `find _build/ -name \*.cma | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ `find _build/ -name \*.cmxa | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ `find _build/ -name \*.a | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ `find _build/ -name \*.byte | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ `find _build/ -name \*.native | grep -v /my$(OCAMLBUILD) | grep -v _build/$$directoryname` \ ; do \ cp $$x _build/$$directoryname/_build; \ done; \ for x in _build/*.docdir; do \ cp -af $$x _build/$$directoryname; \ done; \ for x in main main-local install-libraries-local install-programs-local \ install-local install-data-local clean clean-local \ documentation documentation-local install-documentation-local \ ocamlbuild-stuff \ ; do \ echo "This dummy file prevents make from building the \"$$x\" target." \ > _build/$$directoryname/$$x; \ done; \ (tar czf _build/$$filename -C _build $$directoryname/ && \ (rm -rf _build/$$directoryname && \ rm -f ChangeLog))) && \ echo "Success.") # Automatically generate a nice ChangeLog from bzr's history: ChangeLog: @(if ! [ -d .bzr ]; then \ echo 'No ChangeLog available (bzr metadata are missing)' > $@; \ else \ bzr log --gnu-changelog > $@; \ fi) # Remove generated stuff (the ChangeLog is only removed if we have Darcs # metadata to re-generate it): clean: clean-local @(rm -rf _build; \ find -name "_build*" -prune -o -type f -name \*~ -exec rm -f {} \;; \ find -name "_build*" -prune -o -type f -name \#\*\# -exec rm -f {} \;; \ find -name "_build*" -prune -o -type f -name core -exec rm -f {} \;; \ rm -f _tags meta.ml myocamlbuild.ml; \ if [ -d .bzr ]; then \ rm -f meta.ml.released ChangeLog; \ fi; \ echo "Success.") # Meta-help about the targets defined in this make file: targets: @cat Makefile Makefile.local | grep -B 1 "^[a-z0-9_-]*[:]" | \ awk '/BEGIN/ {r=""} /^[#]/ { r=substr($$0,2); next; } /^[a-z0-9_-]*[-]local[:]/ {r=""; next} /^[a-z0-9_-]*[:]/{split($$0,a,/:/); printf("%s\r\t\t\t--- %s\n",a[1],r); r=""; next} {r=""}' | sort ###################################################################### # Default implementation for '-local' targets: # All the user-definable '-local' targets have an empty implementation # by default: main-local: world-local: data-local: native-libraries-local: byte-libraries-local: libraries-local: native-programs-local: byte-programs-local: programs-local: install-local: uninstall-local: install-programs-local: uninstall-programs-local: install-libraries-local: uninstall-libraries-local: install-data-local: uninstall-data-local: install-configuration-local: uninstall-configuration-local: install-documentation-local: uninstall-documentation-local: dist-local: dist-binary-local: documentation-local: clean-local: # Let's avoid confusion between all and main: they're the same thing # for us, and we only support main-local: all-local: echo 'all-local does not exist. Use main-local instead' exit 1 ##################################################################### # Default compilation flags. The user *is* expected to override or # extend these: DATA = NATIVE_LIBRARIES = BYTE_LIBRARIES = NATIVE_PROGRAMS = BYTE_PROGRAMS = COMPILE_OPTIONS = -thread PP_OPTION = DIRECTORIES_TO_INCLUDE = LIBRARIES_TO_LINK = OBJECTS_TO_LINK = C_OBJECTS_TO_LINK = ##################################################################### # Default rules: # Bytecode libraries: %.cma: ocamlbuild-stuff c-modules @($(OCAMLBUILD) $@) # Native libraries: %.cmxa: ocamlbuild-stuff c-modules @($(OCAMLBUILD) $@) # Bytecode programs: %.byte: ocamlbuild-stuff c-modules @($(call BUILD_WITH_OCAMLBUILD, $@) ) # Native programs: %.native: ocamlbuild-stuff c-modules @($(call BUILD_WITH_OCAMLBUILD, $@) ) # Build the target $(1) using OCamlBuild. ocamlbuild-stuff is assumed # to be already generated. BUILD_WITH_OCAMLBUILD = \ $(OCAMLBUILD) $@; \ if [ -e $@ ]; then \ rm $@; \ echo "Success: $@ was built"; \ else \ echo "FAILURE when building $@"; \ exit -1; \ fi ##################################################################### # Some macros, used internally and possibly by Makefile.local: ##################################################################### # Return 'native' if we have a native compiler available, otherwise # ''. NATIVE = \ (if which ocamlopt.opt &> /dev/null || which ocamlopt &> /dev/null ; then \ echo 'native'; \ else \ echo ''; \ fi) # Return 'byte' if we have a bytecode compiler available, otherwise # ''. BYTE = \ (if which ocamlc.opt &> /dev/null || which ocamlc &> /dev/null; then \ echo 'byte'; \ else \ echo ''; \ fi) # Return 'native' if we have a native compiler available, otherwise # 'byte' if we have a byte compiler; otherwise fail. NATIVE_OR_BYTE = \ (if [ "$$( $(call NATIVE) )" == 'native' ]; then \ echo 'native'; \ elif [ "$$( $(call BYTE) )" == 'byte' ]; then \ echo 'byte'; \ else \ echo 'FATAL ERROR: could not find an ocaml compiler' ">$$native< >$$byte<"; \ exit -1; \ fi) PROCESSOR_NO = $(shell grep "^processor.*:" /proc/cpuinfo | sort | uniq | wc -l) # The log location with respect to the directory _build/ # So, with respect to the Makefile, the log location is _build/_build/_log OCAMLBUILD_LOG=_build/_log LOGFILE=_build/$(OCAMLBUILD_LOG) # Return the proper command line for ocamlbuild, including an option # -byte-plugin if needed: OCAMLBUILD_COMMAND_LINE = \ (if [ $$( $(call NATIVE_OR_BYTE) ) == 'byte' ]; then \ echo 'ocamlbuild -j $(PROCESSOR_NO) -byte-plugin -verbose 2 -log $(OCAMLBUILD_LOG) $(OCAMLBUILD_OPTIONS)'; \ else \ echo 'ocamlbuild -j $(PROCESSOR_NO) -verbose 2 -log $(OCAMLBUILD_LOG) $(OCAMLBUILD_OPTIONS)'; \ fi) # Macro extracting, via source, the value associated to some keys # $(2),..,$(9) in a file $(1). # Example: # $(call SOURCE_AND_TEST,CONFIGME,prefix); # $(call SOURCE_AND_TEST,CONFIGME,prefix,libraryprefix); SOURCE_AND_TEST = \ if ! source $(1) &> /dev/null; then \ echo 'Evaluating $(1) failed.'; \ exit 1; \ fi; \ for i in $(2) $(3) $(4) $(5) $(6) $(7) $(8) $(9) $(10); do \ CMD="VAL=$$`echo $$i`"; eval $$CMD; \ if test -z "$$VAL"; then \ echo "FATAL: $${i} is undefined in $(1)."; \ exit 1; \ fi; \ done; \ unset CMD VAL i # Macro extracting, via grep, the value associated to keys # $(2),..,$(9) in a file $(1). # Examples: # $(call GREP_AND_TEST,META,name); # $(call GREP_AND_TEST,META,name,version); GREP_AND_TEST = \ for i in $(2) $(3) $(4) $(5) $(6) $(7) $(8) $(9) $(10); do \ if ! CMD=`grep "^$$i=" $(1)`; then \ echo "FATAL: $$i is undefined in $(1)."; \ exit 1; \ fi; \ eval $$CMD; \ done; \ unset CMD i # Instance of SOURCE_AND_TEST: source the file "CONFIGME" and test # if the given names are defined # Example: # $(call READ_CONFIG,prefix,libraryprefix); # READ_CONFIG = \ $(call SOURCE_AND_TEST,CONFIGME,$(1),$(2),$(3),$(4),$(5),$(6),$(7),$(8),$(9),$(10)) # Instance of GREP_AND_TEST: read the file "META" searching for a names # for all given names. # Example: # $(call READ_META,name,version); # READ_META = \ $(call GREP_AND_TEST,META,$(1),$(2),$(3),$(4),$(5),$(6),$(7),$(8),$(9),$(10)) # If the value of the 'version' variable contains the substring 'snapshot' then # append to its value the current date, in hacker format. 'version' must be already # defined. No arguments, no output. FIX_VERSION = \ if echo $$version | grep snapshot &> /dev/null; then \ version="$$version-"`date +"%Y-%m-%d"`; \ fi # A simple macro automatically finding all the subdirectories containing ML sources, # setting the variable 'sourcedirectories' to a string containing all such # subdirectories, alphabetically sorted, separated by spaces, and finally echo'ing # the value of sourcedirectories: SOURCE_SUBDIRECTORIES = \ sourcedirectories=''; \ for d in `find \( -path "_build*" -o -name "[.]bzr" -o -name "$(EXCLUDE_FROM_SOURCE_FINDING)" \) -prune -o -type d \ | grep -v /_build\$$ | grep -v /_build/ \ | grep -v ^.$$ | sort`; do \ if ls $$d/*.ml &> /dev/null || \ ls $$d/*.mli &> /dev/null || \ ls $$d/*.mll &> /dev/null || \ ls $$d/*.mly &> /dev/null ; then \ sourcedirectories+="$$d "; \ fi; \ done; \ echo $$sourcedirectories # Set the shell variable $(1) as the string obtained by prefixing each token # in $(2) with the prefix $(3): for example if the shell variable # 'sourcedirectories' is set to './A ./B' then # $(call ADD_PREFIX_TO_EACH_WORD, includes, $$sourcedirectories, -I) # sets the shell variable 'includes' to '-I ./A -I ./B '. # The value of $(1) is finally echo'ed. ADD_PREFIX_TO_EACH_WORD = \ $(call SOURCE_SUBDIRECTORIES); \ result=''; \ for element in $(2); do \ result+="$(3) $$element "; \ done; \ $(1)=$$result; \ echo $$result # This macro expands to the project name, extracted from META. No parameters. # Example: # echo "$(call PROJECT_NAME) is beautiful." PROJECT_NAME = \ $$( $(call GREP_AND_TEST,META,name); \ echo $$name ) # Automatically generate _tags and the $(OCAMLBUILD) plugin. Note that the # target name is never created as a file. This is intentional: those # two targets should be re-generated every time. ocamlbuild-stuff: _tags myocamlbuild.ml meta.ml # We automatically generate the _tags file needed by OCamlBuild. # Every subdirectory containing sources is included. This may be more than what's needed, # but it will always work and require no per-project customization. sed is used to remove # the initial './' from each directory. We refer some settings implemented in our (still # automatically generated) $(OCAMLBUILD) plugin. _tags: @(echo -e "# This file is automatically generated. Please don't edit it.\n" > $@; \ for directory in $$( $(call SOURCE_SUBDIRECTORIES) ); do \ directory=`echo $$directory | sed s/^.\\\\///`; \ echo "<$$directory>: include" >> $@; \ done; \ echo >> $@; \ echo "<**/*.byte>: ourincludesettings, ourbytelinksettings, ourcmodules" >> $@; \ echo "<**/*.{ml,mli,byte,native,cma,cmxa}>: ourincludesettings" >> $@; \ echo "<**/*.{native,cma,cmxa}>: ourcmodules" >> $@ ; \ echo "<**/*.cmx>: ournativecompilesettings" >> $@; \ echo "<**/*.cmo>: ourbytecompilesettings" >> $@; \ echo "<**/*.native>: ourincludesettings, ournativelinksettings" >> $@; \ echo "<**/*.{ml,mli}>: ourocamldocsettings" >> $@ ; \ echo "<**/*.{ml,mli}>: ourppsettings" >> $@) # We automatically generate the $(OCAMLBUILD) plugin customizing the build process # with our user-specified options, include directories, etc.: myocamlbuild.ml: @(echo -e "(* This file is automatically generated. Please don't edit it. *)\n" > $@; \ echo -e "open Ocamlbuild_plugin;;" >> $@; \ echo -e "open Command;;" >> $@; \ echo -e "open Arch;;" >> $@; \ echo -e "open Format;;\n" >> $@; \ echo -en "let our_pp_options = [ " >> $@; \ echo "Just for debugging: PP_OPTION is \"$(PP_OPTION)\""; \ echo "Just for debugging: OCAML_LIBRARYPREFIX is \"$(OCAML_LIBRARYPREFIX)\""; \ echo "Just for debugging: LIBRARYPREFIX is \"$(LIBRARYPREFIX)\""; \ for x in $(PP_OPTION); do \ echo -en "A \"$$x\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_compile_options = [ " >> $@; \ for x in $(COMPILE_OPTIONS); do \ echo -en "A \"$$x\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_byte_compile_options = [ " >> $@; \ for x in $(BYTE_COMPILE_OPTIONS); do \ echo -en "A \"$$x\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_native_compile_options = [ " >> $@; \ for x in $(NATIVE_COMPILE_OPTIONS); do \ echo -en "A \"$$x\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_include_options = [ " >> $@; \ echo -en "A \"-I\"; A \"$(OCAML_LIBRARYPREFIX)\"; " >> $@; \ for x in $(DIRECTORIES_TO_INCLUDE); do \ if test -d $(OCAML_LIBRARYPREFIX)/$$x; then echo -en "A \"-I\"; A \"$(OCAML_LIBRARYPREFIX)/$$x\"; " >> $@; fi; \ done; \ for x in $(DIRECTORIES_TO_INCLUDE); do \ if test -d $(LIBRARYPREFIX)/$$x; then echo -en "A \"-I\"; A \"$(LIBRARYPREFIX)/$$x\"; " >> $@; fi; \ done; \ for x in $(DIRECTORIES_TO_INCLUDE); do \ if test -d ./$$x; then echo -en "A \"-I\"; A \"../$$x\"; " >> $@; fi; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_c_modules = [ " >> $@; \ for x in $(C_OBJECTS_TO_LINK); do \ echo -en "A \"$$x.o\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_c_modules_options = our_c_modules @ [ " >> $@; \ for x in $(C_OBJECTS_TO_LINK_OPTIONS); do \ echo -en "A \"$$x\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_byte_link_options = our_include_options @ [ " >> $@; \ for x in $(LIBRARIES_TO_LINK); do \ echo -en "A \"$$x.cma\"; " >> $@; \ done; \ for x in $(OBJECTS_TO_LINK); do \ echo -en "A \"$$x.cmo\"; " >> $@; \ done; \ echo -e "];;" >> $@; \ echo -en "let our_native_link_options = our_include_options @ [ " >> $@; \ for x in $(LIBRARIES_TO_LINK); do \ echo -en "A \"$$x.cmxa\"; " >> $@; \ done; \ for x in $(OBJECTS_TO_LINK); do \ echo -en "A \"$$x.cmx\"; " >> $@; \ done; \ echo -e "];;\n" >> $@; \ echo -e "dispatch (function After_rules ->" >> $@; \ echo -e " flag [\"ocaml\"; \"compile\"; \"ourincludesettings\"]" >> $@; \ echo -e " (S (our_compile_options @ our_include_options));" >> $@; \ echo -e " flag [\"ocaml\"; \"compile\"; \"ourbytecompilesettings\"]" >> $@; \ echo -e " (S (our_byte_compile_options));" >> $@; \ echo -e " flag [\"ocaml\"; \"compile\"; \"ournativecompilesettings\"]" >> $@; \ echo -e " (S (our_native_compile_options));" >> $@; \ echo -e " flag [\"ocaml\"; \"pp\"; \"ourppsettings\"]" >> $@; \ echo -e " (S our_pp_options);" >> $@; \ echo -e " flag [\"ocaml\"; \"link\"; \"ourbytelinksettings\"]" >> $@; \ echo -e " (S (our_compile_options @ our_byte_link_options));" >> $@; \ echo -e " flag [\"ocaml\"; \"link\"; \"ournativelinksettings\"]" >> $@; \ echo -e " (S (our_compile_options @ our_native_link_options));" >> $@; \ echo -e " flag [\"ocaml\"; \"doc\"; \"ourocamldocsettings\"]" >> $@; \ echo -e " (S ([A \"-keep-code\"; A \"-colorize-code\"] @ our_include_options));" >> $@; \ echo -e " flag [\"ocaml\"; \"link\"; \"ourcmodules\"]" >> $@; \ echo -e " (S our_c_modules_options);" >> $@; \ echo -e " | _ -> ());;" >> $@) # Auto-generate a source file including meta information and configuration-time # settings, which become accessible at runtime: meta.ml: META CONFIGME @(echo "Building $@..." && \ $(call READ_META, name, version); \ $(call READ_CONFIG, prefix, prefix_install, configurationprefix, documentationprefix localeprefix); \ echo -e "(** Automatically generated meta-informations about the project and its building. *)" > $@ && \ echo -e "(* This file is automatically generated; please don't edit it. *)\n" >> $@ && \ echo -e "let name = \"$$name\";;" >> $@ && \ echo -e "let version = \"$$version\";;" >> $@ && \ echo -e "let prefix = \"$$prefix\";;" >> $@ && \ echo -e "let prefix_install = \"$$prefix_install\";;" >> $@ && \ echo -e "let ocaml_version = \"$(OCAML_VERSION)\";;" >> $@ && \ echo -e "let ocaml_libraryprefix = \"$(OCAML_LIBRARYPREFIX)\";;" >> $@ && \ echo -e "let libraryprefix = \"$(LIBRARYPREFIX)\";;" >> $@ && \ echo -e "let configurationprefix = \"$$configurationprefix\";;" >> $@ && \ echo -e "let localeprefix = \"$$localeprefix\";;" >> $@ && \ echo -e "let documentationprefix = \"$$documentationprefix\";;" >> $@ && \ echo -e "let uname = \"$(shell uname -srvmo)\";;" >> $@ && \ echo -e "let build_date = \"$(shell date '+%Y-%m-%d %k:%M:%S %z')\";;" >> $@ && \ if [ -d .bzr ]; then \ echo -e "let revision = \"$$(bzr revno)\";;" >> $@ && \ echo -e "let source_date = \"$$(bzr info --verbose | /bin/grep 'latest revision' | cut -d: -f2- | cut -d' ' -f3-)\";;" >> $@ && \ echo -e "let source_date_utc_yy_mm_dd = \"$$(./Makefile.d/bzr_date -- -u "+%Y-%m-%d")\";;" >> $@ ; \ else \ grep "let revision" > $@ && \ grep "let source_date" > $@ ; \ grep "let source_date_utc_yy_mm_dd" > $@ ; \ fi &&\ echo "Success.") meta.ml.released: meta.ml if [ -d .bzr ]; then \ cp $< $@; \ fi; \ ########################################################################### # Include the project-dependant file (if any) which implements the '-local' # targets: -include Makefile.local -include RPMS/Makefile ocamlbricks-0.90+bzr456.orig/Makefile.d/0000755000175000017500000000000013175721005016662 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/Makefile.d/test_with.sh0000755000175000017500000000524013175721005021234 0ustar lucaslucas#!/bin/bash # This file is part of our reusable OCaml BRICKS library # Copyright (C) 2013 Jean-Vincent Loddo # Copyright (C) 2013 Université Paris 13 # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . TOPLEVEL=${1:-utop} # --- if [[ $2 = "lablgtk2" || $2 = "widgets" ]]; then TEST_WIDGETS=' #require "lablgtk2.auto-init";; let window = GWindow.window ~width:400 ~height:800 ~title:"Testing" ~border_width:10 ();; let _ = window#connect#destroy ~callback:GMain.Main.quit ;; let vbox = GPack.vbox ~packing:window#add () ;; let packing = vbox#pack ~padding:5 ;; let main () = let () = window#show () in GMain.main () ;; let t = Thread.create main () ;; let () = Printf.printf "--- You can create and try widgets simply in this way: (defined objects are: window vbox packing) --- let b = GButton.button ~packing ~label:\"my text\" () ;; ---";; ' fi which $TOPLEVEL &>/dev/null || { echo "Error: $0: $TOPLEVEL not found; install it please." exit 2 } FLATTENED_DIRECTORY=_build/_build.flattened if [[ ! -d $FLATTENED_DIRECTORY ]]; then mkdir -p $FLATTENED_DIRECTORY find _build -path $FLATTENED_DIRECTORY -prune -o -type f -exec cp -fl {} $FLATTENED_DIRECTORY/ \; fi PREAMBLE=$(mktemp) cat > $PREAMBLE </dev/null; then rlwrap $CMD || CODE=$? else echo "Suggestion: install rlwrap for testing with readline (on a debian/ubuntu: apt-get install rlwrap)" $CMD || CODE=$? fi ;; esac rm -f $PREAMBLE exit $CODE ocamlbricks-0.90+bzr456.orig/Makefile.d/ocamlmklib_wrapper.sh0000755000175000017500000000327413175721005023101 0ustar lucaslucas#!/bin/bash # This file is part of our reusable OCaml BRICKS library # Copyright (C) 2009 Jean-Vincent Loddo # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # Usage: # ocamlmklib_wrapper $(OTHER_LIBRARY_FILES_TO_INSTALL)" set -e # Check script dependencies type ocamlobjinfo type ocamlmklib type awk function usage { echo 'Usage (in a Makefile):' echo '$(basename $0) $(C_OBJECTS_TO_LINK)' exit 1 } OBJECTS=$(for i in "$@"; do echo $i.o; done) INCLUDES=$(builtin cd _build &>/dev/null; find -type d -printf "-I %p\n") CMO=$(ocamlobjinfo _build/ocamlbricks.cma | awk '/Unit name/{x=tolower(substr($3,1,1)); r=substr($3,2); printf("%s%s.cmo\n",x,r);}') CMX=$(ocamlobjinfo _build/ocamlbricks.cma | awk '/Unit name/{x=tolower(substr($3,1,1)); r=substr($3,2); printf("%s%s.cmx\n",x,r);}') cd _build/ echo "Rebuilding library with ocamlmklib..." echo '---'; set -x; ocamlc -a -linkall -dllib -locamlbricks_stubs -o ocamlbricks.cma $INCLUDES $CMO; set +x echo '---'; set -x; ocamlopt -a -linkall -cclib -locamlbricks_stubs -o ocamlbricks.cmxa $INCLUDES $CMX; set +x; ls -l ocamlbricks.cm{,x}a ocamlbricks-0.90+bzr456.orig/Makefile.d/bzr_date0000755000175000017500000000341413175721005020404 0ustar lucaslucas#!/bin/bash # This file is part of marionnet # Copyright (C) 2010 Jean-Vincent Loddo # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # Parsing command line arguments FORMAT='r:' function parse_cmdline { unset ARGS while [[ $# -gt 0 ]]; do OPTIND=1 while getopts ":h$FORMAT" flag; do [[ ! $flag = '?' ]] || { echo "*** Illegal option -$OPTARG."; exit 1; } eval "option_${flag}=$OPTIND" eval "option_${flag}_arg='$OPTARG'" done for ((index=1; index. # Usage: # doc.sh -pp "$(PP_OPTION)" -e "$(UNDOCUMENTED)" -i $(DIRECTORIES_TO_INCLUDE) ################################ # Set ocamldoc parameters # ################################ UNDOCUMENTED="meta.ml myocamlbuild.ml" function usage { echo 'Usage (in a Makefile):' echo 'doc.sh -pp "$(PP_OPTION)" -e "$(UNDOCUMENTED)" -i $(DIRECTORIES_TO_INCLUDE)' exit 1 } set -x # The first argument may be empty but must be present. [[ $1 = "-pp" ]] || usage PP_OPTION=$(echo $2) if [[ $PP_OPTION != "" ]]; then PP_OPTION="-pp '$2 -DDOCUMENTATION_OR_DEBUGGING'" fi shift 2 [[ $1 = "-e" ]] || usage UNDOCUMENTED+=" "$(echo $2) for i in $UNDOCUMENTED; do UNDOCUMENTED_FILTER+=" -a ! -name $i" done shift 2 [[ $1 = "-i" ]] || usage shift for i in "$@"; do INCLUDE_LIBS+=" -I +$i" done # ocamldoc parameters: set -x SOURCES=$(builtin cd _build/ &>/dev/null && find . \( -name "*.ml" -o -name "*.mli" \) $UNDOCUMENTED_FILTER) INCLUDES=$(builtin cd _build/ &>/dev/null && find . -type d -printf "-I %p\n") PROJECT=$(basename $PWD) set +x ################################ # Make header and footer # ################################ cd _build/ mkdir -p doc/html # Make header.gif function enrich_index_html { which dot || { echo "Warning: you need dot (graphviz) in order to generated the documentation header."; return 0 } # Get user-defined header and footer [[ -f ../header.html ]] && HEADER_FILE=$(< ../header.html) [[ -f ../footer.html ]] && FOOTER_FILE=$(< ../footer.html) [[ -f ../AUTHORS ]] && AUTHORS_FILE=$(< ../AUTHORS) [[ -f ../AUTHORS ]] && AUTHORS_FILE=$(awk <../AUTHORS '/$/ {print; print "
"; }') # Make dependencies graph set -x; eval ocamldoc $PP_OPTION -dot -d doc/html/ -o doc/html/header0.dot -colorize-code $INCLUDES $INCLUDE_LIBS $SOURCES set +x echo 'Ok, the dependencies graph was built with success.' pushd doc/html >/dev/null grep -v "rankdir=\|size=\|rotate=" header0.dot > header.dot dot header.dot -Tgif -o header.gif HEADER=$(cat < Project

$PROJECT


Dependencies License and authors $HEADER_FILE
EOF ) FOOTER=$(cat <

Dependencies


Dependencies

$FOOTER_FILE

License and authors


$AUTHORS_FILE

EOF ) cat index.html | awk -v h="$HEADER" -v f="$FOOTER" ' /^

.*<.h1><.center>/ {print h; next} /^<\/body>/ {print f ""; next} {print} ' > index1.html mv -f index1.html index.html popd >/dev/null echo 'Ok, header and footer have been included into index.html.' } ################################ # Call ocamldoc # ################################ set -x eval ocamldoc -m A -t $PROJECT $PP_OPTION -sort -keep-code -html -colorize-code -d doc/html/ $INCLUDES $INCLUDE_LIBS $SOURCES set +x echo 'Ok, the documentation was built with success.' enrich_index_html echo 'The documentation has been built with success under _build/doc/html' ocamlbricks-0.90+bzr456.orig/CAMLP4/0000755000175000017500000000000013175721005015643 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/CAMLP4/include_as_string_p4.ml0000644000175000017500000000725413175721005022304 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2008-2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (* ocamlc -I +camlp4 camlp4lib.cma -pp camlp4orf -c include_as_string_p4.ml *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* When this source is read (preprocessing), the variable OCAML4_02_OR_LATER is not set, even if we are compiling with OCaml 4.02.x or later. This means that the pseudo module Bytes will be used in any case, but it's not a problem. *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF open Camlp4.PreCast open Syntax (** Tools for strings. *) module Tool = struct (** Import a file into a string. *) let from_descr (fd:Unix.file_descr) : string = let q = Queue.create () in let buffer_size = 8192 in let buff = Bytes.create buffer_size in let rec loop1 acc_n = begin let n = (Unix.read fd buff 0 buffer_size) in if (n=0) then acc_n else ((Queue.push ((String.sub buff 0 n),n) q); loop1 (acc_n + n)) end in let dst_size = loop1 0 in let dst = Bytes.create dst_size in let rec loop2 dstoff = if dstoff>=dst_size then () else begin let (src,src_size) = Queue.take q in (String.blit src 0 dst dstoff src_size); loop2 (dstoff+src_size) end in (loop2 0); (* (Printf.eprintf "Preprocessing: include_as_string: the length of the included string is %d\n" dst_size);*) dst ;; let from_file (filename:string) : string = let fd = (Unix.openfile filename [Unix.O_RDONLY;Unix.O_RSYNC] 0o640) in let result = from_descr fd in (Unix.close fd); result ;; end;; let readlines ?not_empty_lines_only filename = let ch = open_in filename in let rec loop acc = try loop ((input_line ch)::acc) with End_of_file -> acc in let result = loop [] in close_in ch; if not_empty_lines_only = Some () then List.filter (fun l -> (String.length l)>0) result else result ;; let glob pattern = let filename = Filename.temp_file "globbing" ".list" in let cmd = Printf.sprintf "bash -c 'shopt -s nullglob; for i in %s; do echo $i; done > %s'" pattern filename in if (Sys.command cmd) <> 0 then failwith (Printf.sprintf "include_as_string_p4: glob: error globbing pattern %s" pattern) else (); let result = readlines ~not_empty_lines_only:() filename in Sys.remove filename; result ;; (* -> common tools for camlp4 *) let ex_cons_app_of_list loc xs = List.fold_right (fun x xs -> <:expr@loc< $x$::$xs$ >>) xs <:expr@loc<[]>> ;; EXTEND Gram GLOBAL: expr; expr: LEVEL "top" [ [ "INCLUDE_AS_STRING"; fname = STRING -> let s = Tool.from_file fname in let s = String.escaped s in <:expr< $str:s$ >> | "INCLUDE_AS_STRING_LIST"; pattern = STRING -> let fname_list = glob pattern in let expr_list = List.map (fun fname -> let content = String.escaped (Tool.from_file fname) in <:expr< ( $str:fname$ , $str:content$) >>) fname_list in ex_cons_app_of_list _loc expr_list ] ] ; END; ocamlbricks-0.90+bzr456.orig/CAMLP4/log_module_loading_p4.ml0000644000175000017500000000326313175721005022427 0ustar lucaslucas(* ---------------------------------------------------------- Compilation: $ ocamlc -c -pp camlp4of -I +camlp4 camlp4of.cma log_module_loading_p4.ml Usage: $ ocamlc -c -pp "camlp4of log_module_loading_p4.cmo" your_source.ml ------------------------------------------------------------- *) module type Unit = sig end open Camlp4 (** Module registering the filter at loading-time as a side-effect. *) module Log_module_loading_p4 : Unit = struct module Id = struct let name = "log_module_loading_p4" let version = Sys.ocaml_version end module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters open Ast let first_str_item = ref true ;; (* let () = Printf.kfprintf flush stderr "camlp4: Registering filter log_module_loading_p4\n" ;; *) register_str_item_filter (Ast.map_str_item (function | s when !first_str_item -> (first_str_item := false); let loc = Ast.loc_of_str_item s in let file_name = Loc.file_name loc in (* Avoid circular recursion for Log and Meta modules: *) if List.mem file_name ["log.ml"; "meta.ml"] then begin (* Printf.kfprintf flush stderr "camlp4: Skipping to apply filter log_module_loading_p4 to %s\n" file_name; *) s end else begin (* Printf.kfprintf flush stderr "camlp4: Applying filter log_module_loading_p4 to %s\n" file_name; *) let preambule = <:str_item@loc< let () = Log.printf1 "Loading module %s\n" $str:file_name$ >> in StSem (loc, preambule, s) end | s -> s ) )#str_item ;; end let module M = Camlp4.Register.AstFilter(Id)(Make) in () end (* Log_module_loading_p4 *) ocamlbricks-0.90+bzr456.orig/CAMLP4/include_type_definitions_p4.mli0000644000175000017500000000234713175721005024036 0ustar lucaslucas (* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Include [.mli]'s type definitions into the corresponding [.ml]. *) (** Usage (in your .ml): {[ #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS ".mli" ]} Type definitions are, in outline, mli phrases with '=' or exception definitions. More precisely, only phrases of the following form will be imported: - type ... = ... (and ... = ...)* - module type ... = ... - class type ... = ... - exception ... Any other phrase of .mli will be ignored. *) ocamlbricks-0.90+bzr456.orig/CAMLP4/include_type_definitions_p4.ml0000644000175000017500000001502113175721005023656 0ustar lucaslucas(* This file is part of Marionnet, a virtual network laboratory Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* ocamlc -c -pp camlp4of -I +camlp4 include_type_definitions_p4.ml *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) open Camlp4 (* -*- camlp4o -*- *) module Id = struct let name = "Include_type_definitions" let version = "$Id: include_type_definitions_p4.ml,v 0.1 2009/03/18 16:16:16 $" end (* ----------------------------------- *) (* --- Version for OCaml <= 4.02.y --- *) (* ----------------------------------- *) IFNDEF OCAML4_04_OR_LATER THEN (* ----------------------------------- *) module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax let change_str_item_outermost_location_to loc = function | Ast.StNil _ -> Ast.StNil loc | Ast.StSem (_, str_item1, str_item2) -> Ast.StSem (loc, str_item1, str_item2) | Ast.StCls (_, class_expr) -> Ast.StCls (loc, class_expr) | Ast.StClt (_, class_type) -> Ast.StClt (loc, class_type) | Ast.StTyp (_, ctyp) -> Ast.StTyp (loc, ctyp) | Ast.StExc (_, ctyp, ident) -> Ast.StExc (loc, ctyp, ident) | Ast.StMty (_, str, module_type) -> Ast.StMty (loc, str, module_type) (* Other cases are not possible here: *) | _ -> assert false EXTEND Gram GLOBAL: str_item; str_item: FIRST [ [ "INCLUDE"; "DEFINITIONS"; fname = STRING -> let parse_file file = let ch = open_in file in let st = Stream.of_channel ch in (Gram.parse sig_items (Loc.mk file) st) in let rec list_of_sgSem = function | Ast.SgNil _ -> [] | Ast.SgSem (_, x, xs) -> x :: (list_of_sgSem xs) | x -> [x] in let t = parse_file fname in let is_TyDcl_a_definition = function | Ast.TyDcl (_, _, _, Ast.TyNil _, _) -> false | Ast.TyDcl (_, _, _, _ , _) -> true | _ -> false in let pred = function | Ast.SgTyp (_, (Ast.TyAnd(_,_,_) as t)) -> let xs = Ast.list_of_ctyp t [] in List.for_all is_TyDcl_a_definition xs | Ast.SgTyp (_, tyDcl) when (is_TyDcl_a_definition tyDcl) -> true | Ast.SgExc (_,_) | Ast.SgMty (_,_,_) | Ast.SgClt (_,_) -> true | _ -> false in let l = List.filter pred (list_of_sgSem t) in let mill = function | Ast.SgTyp (a, Ast.TyDcl (b,c,d,e,f)) -> Ast.StTyp (a, Ast.TyDcl (b,c,d,e,f)) | Ast.SgTyp (a, Ast.TyAnd (b,c,d)) -> Ast.StTyp (a, Ast.TyAnd (b,c,d)) | Ast.SgExc (a,b) -> Ast.StExc (a,b,Ast.ONone) | Ast.SgMty (a,b,c) -> Ast.StMty (a,b,c) | Ast.SgClt (a,b) -> Ast.StClt (a,b) | _ -> assert false in let result = Ast.stSem_of_list (List.map mill l) in change_str_item_outermost_location_to _loc result ] ] ; END end (* ----------------------------------- *) (* --- Version for OCaml >= 4.04.y --- *) (* ----------------------------------- *) ELSE (* ----------------------------------- *) module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax let change_str_item_outermost_location_to loc = function | Ast.StNil _ -> Ast.StNil loc | Ast.StSem (_, str_item1, str_item2) -> Ast.StSem (loc, str_item1, str_item2) | Ast.StCls (_, class_expr) -> Ast.StCls (loc, class_expr) | Ast.StClt (_, class_type) -> Ast.StClt (loc, class_type) | Ast.StTyp (_, rec_flag, ctyp) -> Ast.StTyp (loc, rec_flag, ctyp) | Ast.StExc (_, ctyp, ident) -> Ast.StExc (loc, ctyp, ident) | Ast.StMty (_, str, module_type) -> Ast.StMty (loc, str, module_type) (* Other cases are not possible here: *) | _ -> assert false EXTEND Gram GLOBAL: str_item; str_item: FIRST [ [ "INCLUDE"; "DEFINITIONS"; fname = STRING -> let parse_file file = let ch = open_in file in let st = Stream.of_channel ch in (Gram.parse sig_items (Loc.mk file) st) in let rec list_of_sgSem = function | Ast.SgNil _ -> [] | Ast.SgSem (_, x, xs) -> x :: (list_of_sgSem xs) | x -> [x] in let t = parse_file fname in let is_TyDcl_a_definition = function | Ast.TyDcl (_, _, _, Ast.TyNil _, _) -> false | Ast.TyDcl (_, _, _, _ , _) -> true | _ -> false in let pred = function | Ast.SgTyp (_, rec_flag, (Ast.TyAnd(_,_,_) as t)) -> let xs = Ast.list_of_ctyp t [] in List.for_all is_TyDcl_a_definition xs | Ast.SgTyp (_, rec_flag, tyDcl) when (is_TyDcl_a_definition tyDcl) -> true | Ast.SgExc (_,_) | Ast.SgMty (_,_,_) | Ast.SgClt (_,_) -> true | _ -> false in let l = List.filter pred (list_of_sgSem t) in let mill = function | Ast.SgTyp (a, rec_flag, Ast.TyDcl (b,c,d,e,f)) -> Ast.StTyp (a, rec_flag, Ast.TyDcl (b,c,d,e,f)) | Ast.SgTyp (a, rec_flag, Ast.TyAnd (b,c,d)) -> Ast.StTyp (a, rec_flag, Ast.TyAnd (b,c,d)) | Ast.SgExc (a,b) -> Ast.StExc (a,b,Ast.ONone) | Ast.SgMty (a,b,c) -> Ast.StMty (a,b,c) | Ast.SgClt (a,b) -> Ast.StClt (a,b) | _ -> assert false in let result = Ast.stSem_of_list (List.map mill l) in change_str_item_outermost_location_to _loc result ] ] ; END end ENDIF let module M = Register.OCamlSyntaxExtension (Id) (Make) in () ocamlbricks-0.90+bzr456.orig/CAMLP4/common_tools_for_preprocessors.ml0000644000175000017500000000707413175721005024554 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Tools for preprocessors (which cannot use the library). Most of this code is extracted from library's modules. This file must be directly included in the preprocessor, avoiding in this way linking problems. Usage (in your preprocessor): ... module Tool = struct INCLUDE "CAMLP4/common_tools_for_preprocessors.ml" end ... *) module StringExtra = struct let lexists p s = let l = String.length s in let rec loop i = if i>=l then None else if p s.[i] then (Some i) else loop (i+1) in loop 0 let rexists p s = let l = String.length s in let rec loop i = if i<0 then None else if p s.[i] then (Some i) else loop (i-1) in loop (l-1) let not_blank = (fun c -> (c<>' ') && (c<>'\t') && (c<>'\n')) let lstrip s = match lexists not_blank s with | None -> "" | Some i -> String.sub s i (((String.length s))-i) let rstrip s = match rexists not_blank s with | None -> "" | Some i -> String.sub s 0 (i+1) let strip s = match (lexists not_blank s) with | None -> "" | Some i -> (match (rexists not_blank s) with | Some j -> String.sub s i (j-i+1) | None -> assert false ) end module Conf = struct let get_lines file = let fd = open_in file in let rec loop acc = try loop ((input_line fd)::acc) with _ -> acc in loop [] let rec split_equation (s:string) = try let l = String.length s in let p = String.index s '=' in let a = String.sub s 0 p in let a = StringExtra.strip a in let b = String.sub s (p+1) (l-p-1) in let b = StringExtra.strip b in Some (a,b) with _ -> None let conf filename ~default = let xs = get_lines filename in let ys = List.map split_equation xs in let zs = List.filter ((<>)None) ys in let ws = List.map (function Some (x,y) -> (x,y) | _ -> assert false) zs in function key -> try List.assoc key ws with Not_found -> default end module Add_directive_syntax_extension (Unit : sig end) = struct module Id = struct let name = "Directive_syntax_extension" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) : Sig.Camlp4Syntax = struct open Sig include Syntax EXTEND Gram GLOBAL: str_item sig_item; str_item: FIRST [[ "%"; "str_item"; directive = LIDENT; arg = OPT expr -> Printf.kfprintf flush stderr "%%str_item directive \"%s\" found.\n" directive; match arg with | None -> <:str_item< # $directive$ >> | Some arg -> <:str_item< # $directive$ $arg$ >> ]]; sig_item: FIRST [[ "%"; "sig_item"; directive = LIDENT; arg = OPT expr -> Printf.kfprintf flush stderr "%%sig_item directive \"%s\" found.\n" directive; match arg with | None -> <:sig_item< # $directive$ >> | Some arg -> <:sig_item< # $directive$ $arg$ >> ]]; END end (* Make *) let module M = Register.OCamlSyntaxExtension(Id)(Make) in () end (* Directive_syntax_extension *) ocamlbricks-0.90+bzr456.orig/CAMLP4/include_as_string_p4.mli0000644000175000017500000000316113175721005022446 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2008-2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Include a file content as a string constant in your code at compile-time. *) (** Examples: {[ (* Supposing you are compiling with the camlp4 preprocessor : $ ocamlc -c -pp 'camlp4XX -I +ocamlbricks' ... *) #load "include_as_string_p4.cmo";; let content = INCLUDE_AS_STRING "/bin/ls" in Printf.eprintf "The length in word of /bin/ls is %d\n" (String.length content); let ch = open_out "/tmp/ls_copy" in Printf.fprintf ch "%s" content; close_out ch; ;; let put (filename,content) = begin Printf.eprintf "The length in word of %s is %d\n" filename (String.length content); let ch = open_out ("/tmp/"^Filename.basename filename) in Printf.fprintf ch "%s" content; close_out ch; end ;; (* Note the usage of ../ requested with ocamlbuild (because compilation happens in _build/) *) let xs = INCLUDE_AS_STRING_LIST "../share/images/ico.hub.*" in List.iter put xs ;; ]} *) ocamlbricks-0.90+bzr456.orig/CAMLP4/raise_p4.ml0000644000175000017500000000376513175721005017716 0ustar lucaslucas(* ---------------------------------------------------------- Compilation: $ ocamlc -c -pp camlp4of -I +camlp4 camlp4of.cma raise_p4.ml Usage: $ ocamlc -c -pp "camlp4of raise_p4.cmo" your_source.ml ------------------------------------------------------------- *) module type Unit = sig end open Camlp4 (* Module registering the filter at loading-time as a side-effect. *) module Raise_p4 : Unit = struct module Id = struct let name = "raise_p4" let version = Sys.ocaml_version end module Tool = struct INCLUDE "CAMLP4/common_tools_for_preprocessors.ml" end module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters open Ast let module M = Tool.Add_directive_syntax_extension (struct end) in () ;; let escape_raise_filter = ref false ;; let verbosity = ref "1" ;; register_str_item_filter (Ast.map_str_item (function (* %str_item escape_raise_filter *) | <:str_item@loc< # escape_raise_filter >> -> (escape_raise_filter := true); <:str_item@loc< >> (* %str_item enable_raise_filter *) | <:str_item@loc< # enable_raise_filter >> -> (escape_raise_filter := false); <:str_item@loc< >> (* %str_item set_raise_filter_verbosity *) | <:str_item@loc< # set_raise_filter_verbosity $int:k$ >> -> (verbosity := k); <:str_item@loc< >> | s -> s ) )#str_item ;; register_str_item_filter (Ast.map_expr (function | <:expr@loc< raise $e$ >> when (not !escape_raise_filter) -> let loc_as_string = Loc.to_string loc in <:expr@loc< let __raised_exception__ = $e$ in let () = Log.printf2 ~v:$int:!verbosity$ "Raising exception %s at %s\n" (Printexc.to_string __raised_exception__) $str:loc_as_string$ in raise __raised_exception__ >> | e -> e ) )#str_item end let module M = Camlp4.Register.AstFilter(Id)(Make) in () end (* raise_p4 *) ocamlbricks-0.90+bzr456.orig/CAMLP4/where_p4.mli0000644000175000017500000000263713175721005020073 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Backward definitions with keyword [where]. *) (** Usage (in your .ml): {[ #load "where_p4.cmo" ;; WHERE ]} is expanded as: {[ ]} The keyword [where] is accepted instead of [WHERE]. The extension also exists for signature items ([]), and for expressions (but here the legal keyword is only [where]): {[ where = let in ]} {b Associativity}: {[ where where = ( where ) where ]} {b Precedence}: {[ let = where and = let = ( where and ) ]} *) ocamlbricks-0.90+bzr456.orig/CAMLP4/option_extract_p4.ml0000644000175000017500000000170713175721005021647 0ustar lucaslucas(* ---------------------------------------------------------- Compilation: $ ocamlc -c -pp camlp4of -I +camlp4 camlp4of.cma option_extract_p4.ml Usage: $ ocamlc -c -pp "camlp4of option_extract_p4.cmo" your_source.ml ------------------------------------------------------------- *) module type Unit = sig end open Camlp4 (* Module registering the filter at loading-time as a side-effect. *) module Option_extract_traced : Unit = struct module Id = struct let name = "option_extract_p4" let version = Sys.ocaml_version end module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters open Ast register_str_item_filter (Ast.map_expr (function | <:expr@loc< Option.extract >> -> let failwith_msg = Loc.to_string loc in <:expr@loc< Option.extract ~failwith_msg:$str:failwith_msg$ >> | e -> e ) )#str_item end let module M = Camlp4.Register.AstFilter(Id)(Make) in () end (* Option_extract_p4 *) ocamlbricks-0.90+bzr456.orig/CAMLP4/raise_p4.mli0000644000175000017500000000255013175721005020056 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Intercept [raise] calls for logging. *) (** Usage (in your .ml): {[ #load "raise_p4.cmo" ;; ]} With this directive all calls of the form [raise ] will be replaced by: - a call [Log.printf ~v:1 "Raising exception at \n"] - followed by the real [Pervasives.raise ] call. You can set another verbosity level by the directive: {[ %str_item set_raise_filter_verbosity 2;; ]} You can escape the filter in a file with the directive: {[ %str_item escape_raise_filter;; ]} You can reactivate the filter in a file with the directive: {[ %str_item enable_raise_filter;; ]} *) ocamlbricks-0.90+bzr456.orig/CAMLP4/option_extract_p4.mli0000644000175000017500000000211413175721005022011 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Trace [Option.extract] failures. *) (** Usage (in your .ml): {[ #load "option_extract_p4.cmo" ;; ]} With this directive all calls to [Option.extract] will be replaced by [Option.extract ~failwith_msg:]. In this way, when the extraction fails, the raised [Failure] exception contains the location of the caller. *) ocamlbricks-0.90+bzr456.orig/CAMLP4/log_module_loading_p4.mli0000644000175000017500000000205213175721005022573 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Observe the module loading order. *) (** Usage (in your .ml): {[ #load "log_module_loading_p4.cmo" ;; ]} With this directive all files are prepended with the call: {[ Log.printf1 "Loading module \n" ;; ]} In this way you can observe the order of modules loaded by the application. *) ocamlbricks-0.90+bzr456.orig/CAMLP4/where_p4.ml0000644000175000017500000000172713175721005017721 0ustar lucaslucas(* ---------------------------------------------------------- Compilation: $ ocamlc -c -pp camlp4of -I +camlp4 camlp4of.cma where_p4.ml Usage: $ ocamlc -c -pp "camlp4of where_p4.cmo" your_source.ml ------------------------------------------------------------- *) module type Unit = sig end open Camlp4 module Where_p4 : Unit = struct module Id = struct let name = "where_p4" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax EXTEND Gram GLOBAL: str_item sig_item expr binding; str_item: FIRST [[ s1 = str_item; [ "WHERE" | "where" ]; s2 = str_item -> Ast.StSem (_loc,s2,s1) ]]; sig_item: FIRST [[ s1 = sig_item; [ "WHERE" | "where" ]; s2 = sig_item -> Ast.SgSem (_loc,s2,s1) ]]; expr: FIRST [[ e = expr; [ "where" ]; b = binding -> <:expr< let $b$ in $e$ >> ]]; END end (* Make *) let module M = Register.OCamlSyntaxExtension(Id)(Make) in () end (* Where_p4 *) ocamlbricks-0.90+bzr456.orig/CAMLP4/common_tools_for_preprocessors.mli0000644000175000017500000000341513175721005024720 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Tools for preprocessors (which cannot use the library). Most of this code is extracted from library's modules. This file must be directly included in the preprocessor, avoiding in this way linking problems. Usage (in your preprocessor): ... module Tool = struct INCLUDE "CAMLP4/common_tools_for_preprocessors.ml" end ... *) module StringExtra : sig val lexists : (char -> bool) -> string -> int option val rexists : (char -> bool) -> string -> int option val not_blank : char -> bool val lstrip : string -> string val rstrip : string -> string val strip : string -> string end module Conf : sig val get_lines : string -> string list val split_equation : string -> (string * string) option val conf : string -> default:string -> string -> string end module Add_directive_syntax_extension : functor (Unit : sig end) -> sig module Id : sig val name : string val version : string end module Make : functor (Syntax : Camlp4.Sig.Camlp4Syntax) -> Camlp4.Sig.Camlp4Syntax end ocamlbricks-0.90+bzr456.orig/REQUIREMENTS0000644000175000017500000000251113175721005016570 0ustar lucaslucasThis file is part of our reusable OCaml Bricks library Copyright (C) 2008 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Requirements ============ You need several pieces of software to build and use this package; some of them are only used at build time, while others are needed at runtime. Please note that for build-time requirements it's essential to also have the headers/mli files available: if you use the package system of your distro, this translates into having installed also the "-dev" or "-devel" packages. Build-time requirements ======================= GNU Make and OCamlBuild are required (as for all our OCaml projects). And of course you need the OCaml compiler. [To do: fill this...] Runtime requirements ==================== [To do: fill this...] ocamlbricks-0.90+bzr456.orig/EXTRA/0000755000175000017500000000000013175721005015606 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/EXTRA/queueExtra.mli0000644000175000017500000000256313175721005020447 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Queue]. *) val filter : ('a -> bool) -> 'a Queue.t -> unit val filter_copy : ('a -> bool) -> 'a Queue.t -> 'a Queue.t val map : ('a -> 'a) -> 'a Queue.t -> unit val map_copy : ('a -> 'b) -> 'a Queue.t -> 'b Queue.t val rev : 'a Queue.t -> unit val rev_copy : 'a Queue.t -> 'a Queue.t (* The push against discipline (the inserted element will be the first out): *) val copush : 'a Queue.t -> 'a -> unit (* Note that, because of the FIFO discipline, we have the equation: to_list (of_list xs) = List.rev xs *) val to_list : 'a Queue.t -> 'a list val of_list : 'a list -> 'a Queue.t ocamlbricks-0.90+bzr456.orig/EXTRA/unixExtra.ml0000644000175000017500000012567413175721005020146 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following line: it's an ocamldoc workaround!*) (** *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF (** A {e filename} is a string. *) type filename = string;; (** A {e dirname} is a string. *) type dirname = string;; (** A {e content} is a string. *) type content = string;; let apply_ignoring_Unix_error f x = try f x with Unix.Unix_error (_,_,_) -> () ;; let apply_catching_Unix_error ~fallback f x = try f x with Unix.Unix_error (e,b,c) -> fallback (e,b,c) ;; (** The {e user}, {e group} and {e other} permissions [(r,w,x),(r,w,x),(r,w,x)]. *) type symbolic_mode = (bool*bool*bool)*(bool*bool*bool)*(bool*bool*bool) let list_of_symbolic_mode = function ((u_r, u_w, u_x), (g_r, g_w, g_x), (o_r, o_w, o_x)) -> [u_r; u_w; u_x ; g_r; g_w; g_x; o_r; o_w; o_x ] let symbolic_mode_of_list = function | [u_r; u_w; u_x ; g_r; g_w; g_x; o_r; o_w; o_x ] -> ((u_r, u_w, u_x), (g_r, g_w, g_x), (o_r, o_w, o_x)) | xs -> invalid_arg (Printf.sprintf "symbolic_mode_of_list: the length of list is %d but it expected to be 9" (List.length xs)) (** Update a symbolic mode using optial parameters with a meaning similar to the command line options of the unix utility [chmod]. *) let update_symbolic_mode ?u ?g ?o ?a ?r ?w ?x ((u_r, u_w, u_x), (g_r, g_w, g_x), (o_r, o_w, o_x)) = let extract = function Some x -> x | None -> assert false in let user_involved = (u<>None || a<>None) in let u_r = if user_involved && r<>None then (extract r) else u_r in let u_w = if user_involved && w<>None then (extract w) else u_w in let u_x = if user_involved && x<>None then (extract x) else u_x in let group_involved = (g<>None || a<>None) in let g_r = if group_involved && r<>None then (extract r) else g_r in let g_w = if group_involved && w<>None then (extract w) else g_w in let g_x = if group_involved && x<>None then (extract x) else g_x in let other_involved = (o<>None || a<>None) in let o_r = if other_involved && r<>None then (extract r) else o_r in let o_w = if other_involved && w<>None then (extract w) else o_w in let o_x = if other_involved && x<>None then (extract x) else o_x in ((u_r, u_w, u_x), (g_r, g_w, g_x), (o_r, o_w, o_x)) (** The current value of umask. *) let get_umask () : symbolic_mode = let current = Unix.umask 0 in let _ = Unix.umask current in symbolic_mode_of_list (List.map not (Bit.bits_as_booleans_of_int ~length:9 current)) ;; (** Set umask using (a currified version of) a symbolic mode. *) let set_umask um gm om = let i = Bit.int_of_bits_as_booleans (List.map not (list_of_symbolic_mode (um,gm,om))) in ignore (Unix.umask i) ;; (** Update the default file creation mask specifying who is updated: user ([?u]) and/or group ([?g]) and/or other ([?o]) and/or all ([?a]), and what you whant to update and how ([true/false]): read ([?r]) and/or write ([?w]) and/or execution ([?x]). *) let update_umask ?u ?g ?o ?a ?r ?w ?x () = let sm = get_umask () in let (um,gm,om) = update_symbolic_mode ?u ?g ?o ?a ?r ?w ?x sm in set_umask um gm om ;; (** Get the permissions of a file: a triple of booleans respectively for user, group and other. *) let get_perm (fname:filename) : symbolic_mode = try let i = (Unix.stat fname).Unix.st_perm in symbolic_mode_of_list (Bit.bits_as_booleans_of_int ~length:9 i) with | Unix.Unix_error (Unix.ENOENT,"stat", _) -> failwith ("UnixExtra.get_perm: cant stat the file "^fname) ;; (** Set the permissions of a file specifying who is involved: user ([?u]) and/or group ([?g]) and/or other ([?o]) and/or all ([?a]), and what you whant to set and how ([true/false]): read ([?r]) and/or write ([?w]) and/or execution ([?x]). *) let set_perm ?u ?g ?o ?a ?r ?w ?x (fname:filename) = let sm = get_perm fname in let sm = update_symbolic_mode ?u ?g ?o ?a ?r ?w ?x sm in let file_perm = Bit.int_of_bits_as_booleans (list_of_symbolic_mode sm) in Unix.chmod fname file_perm ;; (** Could the process perform some operations on the file: read ([?r]) and/or write ([?w]) and/or execution ([?x])?*) let test_access ?r ?w ?x filename : bool = let xs = [(r,Unix.R_OK); (w,Unix.W_OK); (x,Unix.X_OK)] in let xs = List.filter (fun (v,_)-> v<>None) xs in let xs = Unix.F_OK::(List.map snd xs) in try let () = Unix.access filename xs in true with (* For a strange reason, exceptions are not matched by the pattern `Unix.Unix_error (_, _, _)', even if they should! Unix.Unix_error (_,_,_) -> false So, we have to manipulate exceptions instead of Unix errors: *) e -> false ;; (** Options: ~f stands for Unix.S_REG (* Regular file *), ~d stands for Unix.S_DIR (* Directory *), ~c stands for Unix.S_CHR (* Character device *), ~b stands for Unix.S_BLK (* Block device *), ~l stands for Unix.S_LNK (* Symbolic link *), ~p stands for Unix.S_FIFO (* Named pipe *), ~s stands for Unix.S_SOCK (* Socket *). If any argument is provided, the function tests only the existence. If the option ~l (symlink) is provided with another kind-related option, the later is automatically considered as test(s) for the link's target, not for the link itself. **) let test_kind_and_access ?follow (*kind*) ?f ?d ?c ?b ?l ?p ?s (*access*) ?r ?w ?x filename : bool = let access = test_access ?r ?w ?x filename in access && begin try let xs = [(l, Unix.S_LNK); (f, Unix.S_REG); (d, Unix.S_DIR); (c, Unix.S_CHR); (b, Unix.S_BLK); (p, Unix.S_FIFO); (s, Unix.S_SOCK)] in let xs = List.filter (fun (v,_)-> v<>None) xs in let stat = (if follow = Some () then Unix.stat else Unix.lstat) in let kind = (stat filename).Unix.st_kind in (match xs with | ((Some ()), Unix.S_LNK)::y::ys when kind = Unix.S_LNK -> (* The other options are automatically considered as test(s) for the link's target, not for the link itself: *) let kind = (Unix.stat (* not lstat! *) filename).Unix.st_kind in List.for_all (fun (_, k) -> k = kind) (y::ys) | _ -> List.for_all (fun (_, k) -> k = kind) xs ) with (* looping symlinks are considered as not accessible: *) Unix.Unix_error (Unix.ELOOP, _, _) -> false end (** Equivalent to the bash test [\[\[ -d $1 && -r $1 && -w $1 \]\]]. *) let dir_rw_or_link_to dirname = test_kind_and_access ~follow:() ~d:() ~r:() ~w:() dirname (** Equivalent to the bash test [\[\[ -d $1 && -r $1 && -w $1 && -x $1 \]\]]. *) let dir_rwx_or_link_to dirname = test_kind_and_access ~follow:() ~d:() ~r:() ~w:() ~x:() dirname (** Equivalent to the bash test [\[\[ -f $1 && -r $1 \]\]]. *) let regfile_r_or_link_to filename = test_kind_and_access ~follow:() ~f:() ~r:() filename (** Equivalent to the bash test [\[\[ -f $1 && -r $1 && -w $1 \]\]]. *) let regfile_rw_or_link_to filename = test_kind_and_access ~follow:() ~f:() ~r:() ~w:() filename (** A fresh name is viable if it doesn't exist and its parent directory is writable. *) let viable_freshname x = (not (Sys.file_exists x)) && (let dirname = (Filename.dirname x) in test_kind_and_access ~follow:() ~d:() ~w:() dirname) (** Create a file if necessary with the given permissions (by default equal to [0o644]). *) let touch ?(perm=0o644) (fname:filename) : unit = try (* file exists *) let stat = (Unix.stat fname) in let size = stat.Unix.st_size in let fd = Unix.openfile fname [Unix.O_WRONLY] 0o644 in Unix.ftruncate fd size; Unix.close fd; with | Unix.Unix_error (Unix.EACCES,"open", _) -> failwith ("UnixExtra.touch: cannot open file "^fname) | Unix.Unix_error (Unix.ENOENT,"stat", _) -> begin (* file doesn't exist *) let fd = (Unix.openfile fname [Unix.O_CREAT] perm) in (Unix.close fd) end ;; (** Copy or append a file into another. Optional permissions (by default [0o644]) concern of course the target. -- Adapted from {{:http://www.enseignement.polytechnique.fr/profs/informatique/Didier.Remy/system/camlunix/fich.html}Xavier Leroy and Didier Remy's OS course, Chapter 2}. *) let file_copy_or_append ?(flag=Unix.O_TRUNC) ?(buffer_size=8192) ?perm input_name output_name = let perm = match perm with Some x -> x | None -> (Unix.stat input_name).Unix.st_perm in let buffer = Bytes.create buffer_size in let fd_in = Unix.openfile input_name [Unix.O_RDONLY] 0 in let fd_out = Unix.openfile output_name [Unix.O_WRONLY; Unix.O_CREAT; flag] perm in let rec copy_loop () = match Unix.read fd_in buffer 0 buffer_size with 0 -> () | r -> ignore (Unix.write fd_out buffer 0 r); copy_loop () in copy_loop (); Unix.close fd_in; Unix.close fd_out ;; (** Copy a file into another. Defaults are [buffer_size=8192] and [perm=0o644]. Permissions are used only if the target file must be created. *) let file_copy = file_copy_or_append ~flag:Unix.O_TRUNC ;; (** Append a file into another. Defaults are [buffer_size=8192] and [perm=0o644]. Permissions are used only if the target file must be created. *) let file_append = file_copy_or_append ~flag:Unix.O_APPEND ;; (** Try to rename or copy-and-unlink the source file. *) let file_move input_name output_name = try (* try to rename *) Unix.rename input_name output_name with (* else copy and unlink *) Unix.Unix_error (_,"rename",_) -> begin file_copy input_name output_name; Unix.unlink input_name; end ;; (** Write or rewrite the file with the given content. If the file does not exists, it is created with the given permission (set by default to [0o644]). *) let put ?(perm=0o644) (fname:filename) (x:content) : unit = let fd = (Unix.openfile fname [Unix.O_CREAT; Unix.O_WRONLY; Unix.O_TRUNC] perm) in let n = String.length x in ignore (Unix.write fd x 0 n); (Unix.close fd) ;; (** Alias for [put]. *) let rewrite = put;; (** Similar to the function [put] described above, but the content is {b appended} instead of rewrited. If the file doesn't exists, it is created with the given permissions (set by default to [0o644]). *) let append ?(perm=0o644) (fname:filename) (x:content) = let fd = (Unix.openfile fname [Unix.O_CREAT; Unix.O_WRONLY; Unix.O_APPEND] perm) in let n = String.length x in ignore (Unix.write fd x 0 n); (Unix.close fd) ;; (** Return the {b whole} content (caution!) of the file as a string. Use only for small files. Great for making pipelines. For instance, the following pipeline catches the first line of [/etc/fstab] containing the substring "hda1": {[# "/etc/fstab" => ( cat || String.to_list || Str.grep ".*hda1.*" || hd ) ]}*) let cat (fname:filename) = let fd = (Unix.openfile fname [Unix.O_RDONLY] 0o644) in let len = 16*1024 in let buff = Bytes.create len in let rec loop acc = begin let n = (Unix.read fd buff 0 len) in let s = String.sub buff 0 n in if (n"" then (rewrite fname content)); fname ;; (** More safe (quite paranoic) functions using the [TMPDIR] environment variable and implemented as [Filename.open_temp] wrappers. *) module TMPDIR = struct let default_prefix = (Filename.basename Sys.executable_name)^".";; let rec open_temp ?(perm=0o644) ?(prefix=default_prefix) ?(suffix="") () = (try let (filename,ch) = Filename.open_temp_file prefix suffix in let fd = Unix.descr_of_out_channel ch in (Unix.chmod filename perm); (filename,fd) with e -> (Printf.eprintf "%s: cannot create a temporary file; set the environment variable TMPDIR to resolve this problem.\n" Sys.executable_name); (flush stderr); raise e) let temp_file ?(perm=0o644) ?(prefix=default_prefix) ?(suffix="") () = let (filename,fd) = open_temp ~perm ~prefix ~suffix () in (Unix.close fd); filename end;; (** Heuristic that tries to convert a char into a value of the type: [Unix.file_kind = S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK] The input character must belong to the set ['f';'d';'c';'b';'h';'p';'s'], following the convention of the standard unix [test] command. Otherwise, the result is [None].*) let file_kind_of_char = function | 'f' -> Some Unix.S_REG (* Regular file *) | 'd' -> Some Unix.S_DIR (* Directory *) | 'c' -> Some Unix.S_CHR (* Character device *) | 'b' -> Some Unix.S_BLK (* Block device *) | 'h' | 'L' -> Some Unix.S_LNK (* Symbolic link *) | 'p' -> Some Unix.S_FIFO (* Named pipe *) | 'S' -> Some Unix.S_SOCK (* Socket *) | _ -> None ;; (** [iter_dir f dirname] iterate the function [f] on each entry of the directory [dirname]. -- From {{:http://www.enseignement.polytechnique.fr/profs/informatique/Didier.Remy/system/camlunix/fich.html}Xavier Leroy and Didier Remy's OS course, Chapter 2}. *) let iter_dir f dirname = let d = Unix.opendir dirname in try while true do f (Unix.readdir d) done with End_of_file -> Unix.closedir d ;; (** Support for finding in a directory hierarchy. -- From {{:http://www.enseignement.polytechnique.fr/profs/informatique/Didier.Remy/system/camlunix/fich.html}Xavier Leroy and Didier Remy's OS course, Chapter 2}. *) module Findlib = struct exception Hidden of exn let hide_exn f x = try f x with exn -> raise (Hidden exn);; let reveal_exn f x = try f x with Hidden exn -> raise exn;; let find on_error on_path follow depth roots = let rec loop depth visiting filename = try let infos = (if follow then Unix.stat else Unix.lstat) filename in let continue = hide_exn (on_path filename) infos in let id = infos.Unix.st_dev, infos.Unix.st_ino in if infos.Unix.st_kind = Unix.S_DIR && depth > 0 && continue && (not follow || not (List.mem id visiting)) then let process_child child = if (child <> Filename.current_dir_name && child <> Filename.parent_dir_name) then let child_name = Filename.concat filename child in let visiting = if follow then id :: visiting else visiting in loop (depth-1) visiting child_name in iter_dir process_child filename with (* For a strange reason, exceptions are not matched by the pattern `Unix.Unix_error (e, b, c)', even if they should! | Unix.Unix_error (e, b, c) -> hide_exn on_error (e, b, c) So, we have to manipulate exceptions instead of Unix errors: *) | e -> hide_exn on_error e in reveal_exn (List.iter (loop depth [])) roots ;; end;; (* module Findlib *) (** Find something in an input directory. This function is an interface for the tool [Findlib.find]. The default assignements are: - [follow=false] - [maxdepth=1024] - [kind='_'] which implies no condition on kind - [name=""] which implies no condition on name. The set of characters corresponding to the kind of file are the same of the standard [test] unix command (i.e. ['f';'d';'c';'b';'h';'p';'s']); see the function {!file_kind_of_char} for more details. {b Warning:} use this function with caution: the good version of this function will be a version returning a sequence (stream) instead of a list. {b Examples}: {[# find "/etc/ssh/" ;; : string list = ["/etc/ssh/"; "/etc/ssh/ssh_config"; "/etc/ssh/sshd_config"; "/etc/ssh/ssh_host_key"; "/etc/ssh/ssh_host_dsa_key.pub"; "/etc/ssh/ssh_host_rsa_key.pub"; "/etc/ssh/moduli"; "/etc/ssh/ssh_host_key.pub"; "/etc/ssh/ssh_host_dsa_key"; "/etc/ssh/ssh_host_rsa_key"] # find ~kind:'d' "/etc/ssh/" ;; : string list = ["/etc/ssh/"] # find ~name:"moduli" "/etc/ssh/" ;; : string list = ["/etc/ssh/moduli"] ]} *) let find ?follow ?(maxdepth=1024) ?(kind='_') ?(basename="") ?only_first roots : string list * exn list = let follow = (follow = Some ()) in let result_paths = ref [] in let result_exn = ref [] in let action = let push_on_condition (condition) p = if (condition) then result_paths := (p::!result_paths) else () in match (file_kind_of_char kind, basename) with | (None , "" ) -> fun p infos -> result_paths := (p::!result_paths) | ((Some k), "" ) -> fun p infos -> push_on_condition (infos.Unix.st_kind = k) p | (None , n ) -> fun p infos -> push_on_condition ((Filename.basename p) = n) p | ((Some k), n ) -> fun p infos -> push_on_condition ((infos.Unix.st_kind = k) && ((Filename.basename p) = n)) p in let continue = match only_first with | None -> fun () -> true | Some () -> fun () -> !result_paths = [] in let action p infos = (action p infos; continue ()) in let on_error exn = (result_exn := exn::!result_exn) in let make_result () = (List.rev (!result_paths), List.rev (!result_exn)) in try let () = Findlib.find on_error action follow maxdepth roots in make_result () with exn -> let () = (result_exn := exn::!result_exn) in make_result () ;; (* For the same strange reason mentioned above, this redefinition doesn't run correctly : the second part of the result (the list of errors) is each time the empty list... However, outside the module UnixExtra the result may be kept and correctly matched. *) (* let find ?follow ?maxdepth ?kind ?basename ?only_first roots = let (xs,es) = find ?follow ?maxdepth ?kind ?basename ?only_first roots in let es2 = lazy let es1 = List.filter (function Unix.Unix_error (_,_,_) -> true | _ -> false) es in List.map (function Unix.Unix_error (e,b,c) -> (e,b,c) | _ -> assert false) es1 in (xs, es2) *) let find_fold ?follow ?maxdepth ?kind ?basename ?only_first (f:('a -> string * string list * exn list -> 'a)) acc roots : 'a = List.fold_left (fun acc root -> let (xs,es) = find ?follow ?maxdepth ?kind ?basename ?only_first [root] in f acc (root,xs,es)) acc roots let find_first_and_map ?follow ?maxdepth ?kind ?basename (f:string -> string -> 'a) roots : 'a option = List.fold_left (fun acc root -> if acc<>None then acc else let (xs,es) = find ?follow ?maxdepth ?kind ?basename ~only_first:() [root] in match xs with | x::_ -> Some (f root x) | [] -> None ) None roots (** Support for input passwords. -- From {{:http://www.enseignement.polytechnique.fr/profs/informatique/Didier.Remy/system/camlunix/fich.html}Xavier Leroy and Didier Remy's OS course, Chapter 2}. *) module Passwdlib = struct let read_passwd message = match try let default = Unix.tcgetattr Unix.stdin in let silent = { default with Unix.c_echo = false; Unix.c_echoe = false; Unix.c_echok = false; Unix.c_echonl = false; } in Some (default, silent) with _ -> None with | None -> input_line Pervasives.stdin | Some (default, silent) -> print_string message; flush Pervasives.stdout; Unix.tcsetattr Unix.stdin Unix.TCSANOW silent; try let s = input_line Pervasives.stdin in Unix.tcsetattr Unix.stdin Unix.TCSANOW default; s with x -> Unix.tcsetattr Unix.stdin Unix.TCSANOW default; raise x;; end;; (* Passwdlib *) (** Prompt for a password. The terminal is set for hiding the characters read from keyboard. *) let read_passwd prompt = Passwdlib.read_passwd prompt;; let string_of_process_status = function | Unix.WEXITED code -> (Printf.sprintf "Unix.WEXITED %d" code) | Unix.WSIGNALED signal -> (Printf.sprintf "Unix.WSIGNALED %d" signal) | Unix.WSTOPPED signal -> (Printf.sprintf "Unix.WSTOPPED %d" signal) ;; (** A {e command} is something understandable by the shell. *) type command = string;; (** A {e program} is a file binary (which will be found by the system in [PATH]). *) type program = string;; (** Search the directory containing the executable. Candidates are taken from the environment variable [PATH]. The result [None] means not found. {b Examples}: {[# UnixExtra.path_of_implicit "ls" ;; : string option = Some "/bin" # UnixExtra.path_of_implicit "foo" ;; : string option = None ]} *) let path_of_implicit p = let is_there_an_executable p d = let filelist = Array.to_list (Sys.readdir d) in (List.mem p filelist) && (test_access ~x:() (Filename.concat d p)) in let dirs = StringExtra.split ~d:':' (Sys.getenv "PATH") in let dirs = List.filter (test_access ~r:()) dirs in try Some(List.find (is_there_an_executable p) dirs) with Not_found -> None (** Run Unix.system with the given argument, and raise exception in case of failure; return unit on success. *) let system_or_fail ?(hide_output=false) ?(hide_errors=false) command = let suffix1 = if hide_output then " 1>/dev/null" else "" in let suffix2 = if hide_errors then " 2>/dev/null" else "" in let command = Printf.sprintf "%s%s%s" command suffix1 suffix2 in match Unix.system command with | Unix.WEXITED 0 -> () | Unix.WEXITED n -> failwith (Printf.sprintf "Unix.system: the process exited with %i" n) | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> failwith "Unix.system: the process was signaled or stopped" ;; open Endpoint;; (** [kill_safe pid signal] send the [signal] to the process [pid] ignoring exceptions. *) let kill_safe pid signal = try Unix.kill pid signal with _ -> () ;; exception Signal_forward of int;; exception Waitpid;; type waiting_events = { mutable forwarded_signal : int option ; mutable process_status : Unix.process_status option; mutable waitpid_exn : bool ; };; let new_waiting_events () = { forwarded_signal = None ; process_status = None ; waitpid_exn = false ; };; let rec wait_child child_pid events = try begin let (_, process_status) = (Unix.waitpid [] child_pid) in (events.process_status <- Some process_status); match process_status with | Unix.WEXITED code -> () (* return *) | Unix.WSIGNALED signal | Unix.WSTOPPED signal -> (events.forwarded_signal <- Some signal); wait_child child_pid events end with | Unix.Unix_error(_,_,_) -> (events.waitpid_exn <- true) ;; let new_handler child_pid events = Sys.Signal_handle (fun s -> (events.forwarded_signal <- Some s); (kill_safe child_pid s); (wait_child child_pid events)) ;; (** Create process with [?stdin=Unix.stdin], [?stdout=Unix.stdout] and [?stderr=Unix.stderr] connected to a given source and sinks, then wait until its termination. During waiting, some signals could be forwarded by the father to the child specifying the argument [?(forward = [Sys.sigint; Sys.sigabrt; Sys.sigquit; Sys.sigterm; Sys.sigcont])]. The two last parameters are the program (binary) and its list of actual parameters. The process is created with the primitive [Unix.create_process]. If the process exits with [Unix.WEXITED code] the code is returned. Otherwise an exception is raised, more specifically: - [Signal_forward s] is raised if the father has transmitted a signal (certainly the reason of the violent termination of the child); - [Waitpid] is raised if the internal call to [Unix.waitpid] has failed for some unknown reasons.*) let create_process_and_wait ?(stdin = Source.Unix_descr Unix.stdin) ?(stdout = Sink.Unix_descr Unix.stdout) ?(stderr = Sink.Unix_descr Unix.stderr) ?pseudo ?(forward = [Sys.sigint; Sys.sigabrt; Sys.sigquit; Sys.sigterm]) ?register_pid program arguments = let (stdin, stdin_must_be_closed ) = Source.to_file_descr stdin in let (stdout, stdout_must_be_closed) = Sink.to_file_descr stdout in let (stderr, stderr_must_be_closed) = Sink.to_file_descr stderr in let events = new_waiting_events () in let name = match pseudo with None -> program | Some name -> name in let argv = (Array.of_list (name :: arguments)) in let child_pid = (Unix.create_process program argv stdin stdout stderr) in (match register_pid with None -> () | Some f -> f child_pid); let handler = new_handler child_pid events in let handler_backups = List.map (fun s -> (s, (Sys.signal s handler))) forward in let restore_handlers () = List.iter (fun (s,h) -> Sys.set_signal s h) handler_backups in (wait_child child_pid events); (restore_handlers ()); (if stdin_must_be_closed then Unix.close stdin); (if stdout_must_be_closed then Unix.close stdout); (if stderr_must_be_closed then Unix.close stderr); match events with | { process_status = Some (Unix.WEXITED code); forwarded_signal = None; waitpid_exn = false } -> code | { process_status = Some (Unix.WEXITED code); forwarded_signal = Some s } when s=Sys.sigcont -> code | { forwarded_signal = Some s ; waitpid_exn = true } -> (raise (Signal_forward s)) | { waitpid_exn = true } -> (raise Waitpid) | _ -> (assert false) ;; (** High-level result: (code, stdout, stderr) *) type process_result = (int * string * string) ;; (** Similar to [create_process_and_wait], but the results on endpoints [stdout] and [stderr] are converted in strings and returned. However, if the optional parameters [stdout] and [stderr] are provided, their corresponding string in the result will be empty. *) let create_process_and_wait_then_get_result ?stdin ?stdout ?stderr ?pseudo ?forward ?register_pid (program:program) (argv_list:string list) = begin let define_sink_and_string_maker optional_sink = (match optional_sink with | Some x -> (x, fun () -> "") | None -> let q = String_queue.create () in (Sink.String_queue q), (fun () -> String_queue.concat q) ) in let (stdout, stdout_string_maker) = define_sink_and_string_maker stdout in let (stderr, stderr_string_maker) = define_sink_and_string_maker stderr in let code = try create_process_and_wait ?stdin ~stdout ~stderr ?pseudo ?forward ?register_pid program argv_list with _ -> (-1) in let stdout_string = stdout_string_maker () in let stderr_string = stderr_string_maker () in (code,stdout_string,stderr_string) end ;; (* Convert a string option into a shell specification. The shell "bash" is our default. *) let shell_of_string_option = function | None -> "bash" | Some shell -> shell ;; (** [run command] exec the shell ([bash] by default) with arguments [\["-c";command\]] and return the pair (output, exit-code). A string can be specified as standard input for the command. The flag [trace] (by default set to [false]) permits to obtain some informations about the running on [stderr]. {b Examples}: {[# run "ls /etc/*tab";; : string * Unix.process_status = ("/etc/crontab\n/etc/fstab\n/etc/inittab\n/etc/mtab\n/etc/quotatab\n", Unix.WEXITED 0) # run ~input:"hello" "cat";; : string * Unix.process_status = ("hello", Unix.WEXITED 0) # run ~shell:"dash" ~input:"HELLO" "head -n 1 /etc/passwd /dev/stdin | cut -c-15";; : string * Unix.process_status = ("==> /etc/passwd\nat:x:25:25:Batc\n\n==> /dev/stdin \nHELLO\n", Unix.WEXITED 0) ]} *) let run ?shell ?(trace:bool=false) ?input (cmd:command) : string * Unix.process_status = let shell = shell_of_string_option shell in let (stdin,inp) = match input with | None -> (Source.Unix_descr Unix.stdin, "") | Some x -> (Source.String x, x) in let queue = String_queue.create () in let stdout = Sink.String_queue queue in let code = create_process_and_wait ~stdin ~stdout shell ["-c";cmd] in let out = (String_queue.concat queue) in (if trace then begin Printf.eprintf "UnixExtra.run: tracing: input is '%s'\n" inp; Printf.eprintf "UnixExtra.run: tracing: command is '%s'\n" cmd; Printf.eprintf "UnixExtra.run: tracing: output is '%s'\n" out; flush stderr; end); (out, Unix.WEXITED code) ;; (** As [run], but ignoring the exit-code. This function is simply a shortcut for the composition of [run] with [fst]. {b Examples}: {[# shell "date";; : string = "ven avr 13 18:34:02 CEST 2007\n" # String.Text.Matrix.of_string (shell "wc -l /etc/*tab");; : string list list = [["8"; "/etc/crontab"]; ["20"; "/etc/fstab"]; ["98"; "/etc/inittab"]; ["11"; "/etc/mtab"]; ["127"; "/etc/naccttab"]; ["9"; "/etc/quotatab"]; ["273"; "total"]] ]}*) let shell ?shell ?(trace:bool=false) ?(input:string="") cmd = fst(run ~shell:(shell_of_string_option shell) ~trace ~input cmd) ;; (** A Unix future is a future containing the exit code and the two strings outcoming from stdout and stderr. The negative exit code (-1) means that the process didn't well exited. *) type future = (int * string * string) Future.t ;; (** Similar to {!val:UnixExtra.future}, but with a continuation executed {b within} the thread. The default for [forward] here is the empty list [[]]. *) let kfuture ?stdin ?stdout ?stderr ?pseudo ?(forward=[]) ?register_pid (program:program) (argv_list:string list) k = begin let define_sink_and_string_maker optional_sink = (match optional_sink with | Some x -> (x, fun () -> "") | None -> let q = String_queue.create () in (Sink.String_queue q), (fun () -> String_queue.concat q) ) in let (stdout, stdout_string_maker) = define_sink_and_string_maker stdout in let (stderr, stderr_string_maker) = define_sink_and_string_maker stderr in let future = Future.future (fun () -> begin let code = try create_process_and_wait ?stdin ~stdout ~stderr ?pseudo ~forward ?register_pid program argv_list with _ -> (-1) in let stdout_string = stdout_string_maker () in let stderr_string = stderr_string_maker () in (k code stdout_string stderr_string) end) () in future end ;; (** Create a {!type:UnixExtra.process_result} {!type:Future.t} that you can manage as usual with functions of the module {!Future}. *) let future ?stdin ?stdout ?stderr ?pseudo ?(forward=[]) ?register_pid program argv_list = kfuture ?stdin ?stdout ?stderr ?pseudo ~forward ?register_pid program argv_list (fun x y z -> (x,y,z)) (** With the {b content} provided by the user, a script file is created on the fly, executed and finally removed. The result is a 3-uple with the exit code and the two strings outcoming from stdout and stderr. *) let script ?stdin ?stdout ?stderr ?pseudo ?(forward=[]) ?register_pid (content:content) (argv_list:string list) : (int * string * string) = begin let program = temp_file ~perm:0o755 ~suffix:".sh" ~content () in try let f = future ?stdin ?stdout ?stderr ?pseudo ~forward ?register_pid program argv_list in let result = Future.touch f in (Unix.unlink program); result with e -> ((Unix.unlink program); raise e) end ;; let script_future ?stdin ?stdout ?stderr ?pseudo ?(forward=[]) ?register_pid (content:content) (argv_list:string list) : (int * string * string) Future.t = begin let program = temp_file ~perm:0o755 ~suffix:".sh" ~content () in try let k x y z = let () = Unix.unlink program in (x,y,z) in kfuture ?stdin ?stdout ?stderr ?pseudo ~forward ?register_pid program argv_list k with e -> ((Unix.unlink program); raise e) end ;; (** Tools for manipulating directory entries: *) module Dir = struct type t = string (* This protection is necessary because there is a time period between the call of `Unix.readdir' and the successive call to `Unix.stat'. In this period the entry may be deleted. *) let protected_pred p x = try (p x) with Unix.Unix_error (Unix.ENOENT, _, _) -> false let file_kind_pred_of ?entry_kind ?follow dir = let stat = (if follow=Some () then Unix.stat else Unix.lstat) in match entry_kind with | None -> (fun _ -> true) | Some file_kind -> protected_pred (fun x -> (stat (Filename.concat dir x)).Unix.st_kind = file_kind) let fold ?entry_kind ?follow f zero dir = let file_kind_pred = file_kind_pred_of ?entry_kind ?follow dir in let dir_handle = Unix.opendir dir in let rec loop acc = try let x = Unix.readdir dir_handle in let acc = if (x = ".") || (x = "..") || (not (file_kind_pred x)) then acc else (f acc x) in loop acc with End_of_file -> acc in let result = (loop zero) in let () = Unix.closedir dir_handle in result let iter ?entry_kind ?follow f dir = fold ?entry_kind ?follow (fun () x -> f x) () dir let to_list ?entry_kind ?follow dir = List.rev (fold ?entry_kind ?follow (fun xs x -> x::xs) [] dir) let map ?entry_kind ?follow f dir = List.rev (fold ?entry_kind ?follow (fun xs x -> (f x)::xs) [] dir) (* --- with kind --- *) (* This protection is necessary because there is a time period between the call of `Unix.readdir' and the successive call to `Unix.stat'. In this period the entry may be deleted. *) let file_kind_of ?follow dir = let stat = (if follow=Some () then Unix.stat else Unix.lstat) in fun x -> try Some (stat (Filename.concat dir x)).Unix.st_kind with Unix.Unix_error (Unix.ENOENT, _, _) -> None let fold_with_kind ?follow f zero dir = let file_kind : string -> Unix.file_kind option = file_kind_of ?follow dir in let dir_handle = Unix.opendir dir in let rec loop acc = try let x = Unix.readdir dir_handle in let acc = if (x = ".") || (x = "..") then acc else match (file_kind x) with | Some k -> f acc x k | None -> acc in loop acc with End_of_file -> acc in let result = (loop zero) in let () = Unix.closedir dir_handle in result let iter_with_kind ?follow f dir = fold_with_kind ?follow (fun () x k -> f x k) () dir let to_list_with_kind ?follow dir = List.rev (fold_with_kind ?follow (fun xs x k -> (x,k)::xs) [] dir) let map_with_kind ?follow f dir = List.rev (fold_with_kind ?follow (fun xs x k -> (f x k)::xs) [] dir) end (* Dir *) type pid = int (** [does_process_exist pid] return true if and only if the [pid] is alive in the system. *) external does_process_exist : int -> bool = "does_process_exist_c";; let is_process_alive = does_process_exist module Process = struct type status = | WUNCHANGED (** Used when non-blocking calls with WNOHANG return immediately without value *) | WEXITED of int (** The process terminated normally by exit; the argument is the return code. *) | WSIGNALED of int (** The process was killed by a signal; the argument is the signal number. *) | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) | WCONTINUED (** The process was resumed *) type wait_flag = | WNOHANG (** do not block if no child has died yet, but immediately return with a pid equal to 0. *) | WUNTRACED (** report also the children that receive stop signals. *) | WCONTINUE (** report also if the children resume *) external waitpid : wait_flag list -> pid -> int * status = "waitpid_c" let string_of_status = function | WUNCHANGED -> (Printf.sprintf "Process.WUNCHANGED") | WEXITED code -> (Printf.sprintf "Process.WEXITED %d" code) | WSIGNALED signal -> (Printf.sprintf "Process.WSIGNALED %d" signal) | WSTOPPED signal -> (Printf.sprintf "Process.WSTOPPED %d" signal) | WCONTINUED -> (Printf.sprintf "Process.WCONTINUED") (** Similar to waitpid but protected from the exception [Unix.Unix_error (Unix.EINTR, _, _)]. If this exception is raised, the function recall itself in order to wait again: *) let rec waitpid_non_intr ?(wait_flags=[]) pid = try Either.Right (waitpid wait_flags pid) with | Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr ~wait_flags pid | e -> Either.Left e (** Similar to [waitpid_non_intr] but protected also from the exception: [Unix.Unix_error (Unix.ECHILD, _, _)] which may simply mean that the process doesn't exist or it is already terminated (and wait-ed by someone else). In this case, the function returns immediately. However, if this exception is raised when the process is still alive, this means that the process cannot be wait-ed (is not a child or a descendant). In this case, an exception [Invalid_argument] is raised. *) let join_process pid : unit = let invalid_arg () = let msg = Printf.sprintf "UnixExtra.join_process: pid %d is not a child neither a descendant" pid in invalid_arg msg in let wait_flags = [] in match (waitpid_non_intr ~wait_flags pid) with | Either.Left (Unix.Unix_error (Unix.ECHILD, _, _)) -> if is_process_alive pid then invalid_arg () (* Not a child neither a descendant *) else () (* Unexistent or already dead process *) | Either.Left e -> raise e | Either.Right (_, WEXITED _) -> () | Either.Right (_, WSIGNALED _) -> () | Either.Right (_, WSTOPPED _) -> assert false | Either.Right (_, WCONTINUED) -> assert false | Either.Right (_, WUNCHANGED) -> assert false end (* Process *) (** Return the current date formatted as a string like ["2010-06-24.17:34:25"]. Dashes, dot and colons may be replaced by something else using the optional parameters. *) let date ?gmt ?(dash="-") ?(dot=".") ?(colon=":") ?no_time ?no_sec ?no_date () = let time_function = match gmt with | None -> Unix.localtime | Some () -> Unix.gmtime in let tm = time_function (Unix.time ()) in match no_time, no_sec, no_date with | None, None, None -> Printf.sprintf "%4d%s%02d%s%02d%s%02d%s%02d%s%02d" (1900+tm.Unix.tm_year) dash (1+tm.Unix.tm_mon) dash (tm.Unix.tm_mday) dot (tm.Unix.tm_hour) colon (tm.Unix.tm_min) colon (tm.Unix.tm_sec) | None, Some (), None -> Printf.sprintf "%4d%s%02d%s%02d%s%02d%s%02d" (1900+tm.Unix.tm_year) dash (1+tm.Unix.tm_mon) dash (tm.Unix.tm_mday) dot (tm.Unix.tm_hour) colon (tm.Unix.tm_min) | Some (), _, None -> Printf.sprintf "%4d%s%02d%s%02d" (1900+tm.Unix.tm_year) dash (1+tm.Unix.tm_mon) dash (tm.Unix.tm_mday) | None, None, Some () -> Printf.sprintf "%02d%s%02d%s%02d" (tm.Unix.tm_hour) colon (tm.Unix.tm_min) colon (tm.Unix.tm_sec) | None, Some (), Some () -> Printf.sprintf "%02d%s%02d" (tm.Unix.tm_hour) colon (tm.Unix.tm_min) | Some (), _, Some () -> invalid_arg "UnixExtra.date: strangely called with ~no_time:() and ~no_date:()" (** Resolve a symbolic link if the argument is a symbolic link, otherwise return the argument (identity). {b Example}: {[ # resolve_symlink "/initrd.img" ;; : string = "//boot/initrd.img-2.6.32-24-generic" # resolve_symlink "/not/existing/file" ;; : string = "/not/existing/file" ]} *) let resolve_symlink ?(max_hops=64) filename = let rec loop max_hops filename = begin try if max_hops <= 0 then filename else let target = Unix.readlink filename in let target = (match (Filename.is_relative target) with | true -> let dir = Filename.dirname filename in Printf.sprintf "%s/%s" dir target | false -> target ) in if target = filename then target else (loop (max_hops-1) target) with _ -> filename end in loop max_hops filename let is_symlink filename = try ignore (Unix.readlink filename); true with _ -> false (* This version is thread_unsafe because of Sys.chdir. *) module Thread_unsafe = struct (** See the unix command realpath: *) let realpath ?s x = let x = match s with | None -> resolve_symlink x | Some () -> x in let cwd = Sys.getcwd () in let result = try match (Filename.basename x) with | ".." -> let dir = x in (Sys.chdir dir); Some (Sys.getcwd ()) | "." -> let dir = Filename.dirname x in (Sys.chdir dir); Some (Sys.getcwd ()) | basename -> let dir = Filename.dirname x in (Sys.chdir dir); let dir' = Sys.getcwd () in let y = Filename.concat dir' basename in Some y with _ -> None in (Sys.chdir cwd); result end module Mutex = MutexExtra.Recursive let mutex = Mutex.create () let realpath ?s x = Mutex.apply_with_mutex mutex (Thread_unsafe.realpath ?s) x (** Version working in the both cases implicit/explicit program reference as a shell interpreter. *) let is_executable program = if Filename.is_implicit program then (path_of_implicit program) <> None else (Sys.file_exists program) && (test_access ~x:() program) let realpath_alias = realpath (** Version working in the both cases implicit/explicit program reference as a shell interpreter. *) let resolve_executable ?realpath program = let result = if Filename.is_implicit program then Option.map (fun path -> Filename.concat path program) (path_of_implicit program) else if not (Sys.file_exists program) then None else if not (test_access ~x:() program) then None else Some program in if realpath = None then result else Option.bind result (fun pathname -> realpath_alias pathname) ocamlbricks-0.90+bzr456.orig/EXTRA/sysExtra.ml0000644000175000017500000004047013175721005017767 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007-2012 Jean-Vincent Loddo, Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) IFNDEF OCAML4_04_OR_LATER THEN let lowercase = String.lowercase ELSE let lowercase = String.lowercase_ascii ENDIF (** More sophisticated version of [Sys.getenv]. The result is None if and only if something goes wrong in retrieving and converting the value from the environment (key not present, or associated to the empty string, or associated to a value which hasn't the expected type or doesn't verify the condition implicitely denoted by the method name). {b Examples}: {[# (meaningful_getenv "HOME")#existing_directory ;; : string option = Some "/home/foo" # (meaningful_getenv "TMPDIR")#existing_directory ;; : string option = None # (meaningful_getenv "TMPDIR")#non_empty_string ;; : string option = None ]} **) let meaningful_getenv x = let ov = try (match Sys.getenv x with | "" -> None | v -> Some v ) with Not_found -> None in object method non_empty_string = ov method int = try Option.map int_of_string ov with _ -> None method float = try Option.map float_of_string ov with _ -> None method bool = try Option.map (fun v -> bool_of_string (lowercase v)) ov with _ -> None method existing_file = Option.filter (Sys.file_exists) ov method existing_directory = try Option.filter (Sys.is_directory) ov with _ -> None end (** Reads a given directory, thus select and convert names. Returns the list of formatted names. *) let readdir_as_list ?only_directories ?only_not_directories ?(name_filter:(string->bool)=(fun x -> true)) ?(name_converter:(string->string)=(fun x->x)) (dir:string) = try begin let filelist = (Array.to_list (Sys.readdir dir)) in let first_filter = match only_directories, only_not_directories with | None, None -> (fun x -> true) | Some (), None -> Sys.is_directory | None, Some () -> (fun x -> not (Sys.is_directory x)) | Some (), Some () -> invalid_arg "SystExtra.readdir_as_list: ?only_directories and ?only_not_directories both set." in let safe_name_filter = (fun name -> (try (name_filter name) with _ -> false)) in let selected_items = List.filter (fun x -> (first_filter (dir^"/"^x)) && (safe_name_filter x)) filelist in List.map name_converter selected_items end with | (Invalid_argument msg) as e -> raise e | _ -> [] (** [put content filename] rewrite [filename] with the given [content] string. An optional [~callback] may be provided in order to catch the exception [(Sys_error msg)]. By default, the callback print the [msg] on [stderr] and exit from program with the exit code [1]. *) let put = let std_callback msg = ((Printf.eprintf "%s" msg); exit 1) in fun ?(callback=std_callback) (content:string) (filename:string) -> (try let out_channel = open_out filename in (Printf.fprintf out_channel "%s" content); (close_out out_channel); with Sys_error msg -> callback msg) (* Note: list built using "kill -l" on a GNU/Linux: *) let signal_list = [ (1,"SIGHUP"); (2,"SIGINT"); (3,"SIGQUIT"); (4,"SIGILL"); (5,"SIGTRAP"); (6,"SIGABRT"); (7,"SIGBUS"); (8,"SIGFPE"); (9,"SIGKILL"); (10,"SIGUSR1"); (11,"SIGSEGV"); (12,"SIGUSR2"); (13,"SIGPIPE"); (14,"SIGALRM"); (15,"SIGTERM"); (16,"SIGSTKFLT"); (17,"SIGCHLD"); (18,"SIGCONT"); (19,"SIGSTOP"); (20,"SIGTSTP"); (21,"SIGTTIN"); (22,"SIGTTOU"); (23,"SIGURG"); (24,"SIGXCPU"); (25,"SIGXFSZ"); (26,"SIGVTALRM"); (27,"SIGPROF"); (28,"SIGWINCH"); (29,"SIGIO"); (30,"SIGPWR"); (31,"SIGSYS"); (34,"SIGRTMIN"); (35,"SIGRTMIN+1"); (36,"SIGRTMIN+2"); (37,"SIGRTMIN+3"); (38,"SIGRTMIN+4"); (39,"SIGRTMIN+5"); (40,"SIGRTMIN+6"); (41,"SIGRTMIN+7"); (42,"SIGRTMIN+8"); (43,"SIGRTMIN+9"); (44,"SIGRTMIN+10"); (45,"SIGRTMIN+11"); (46,"SIGRTMIN+12"); (47,"SIGRTMIN+13"); (48,"SIGRTMIN+14"); (49,"SIGRTMIN+15"); (50,"SIGRTMAX-14"); (51,"SIGRTMAX-13"); (52,"SIGRTMAX-12"); (53,"SIGRTMAX-11"); (54,"SIGRTMAX-10"); (55,"SIGRTMAX-9"); (56,"SIGRTMAX-8"); (57,"SIGRTMAX-7"); (58,"SIGRTMAX-6"); (59,"SIGRTMAX-5"); (60,"SIGRTMAX-4"); (61,"SIGRTMAX-3"); (62,"SIGRTMAX-2"); (63,"SIGRTMAX-1"); (64,"SIGRTMAX"); ];; let the_SIGRTMIN_and_SIGRTMAX_descr = "Real-time signal for application-defined purposes" ;; type default_actions = Term | Core | Stop | Cont | Ign ;; let string_of_default_action = function | Term -> "Term" | Core -> "Core" | Stop -> "Stop" | Cont -> "Cont" | Ign -> "Ign" ;; (* Source: http://www.kernel.org/doc/man-pages/online/pages/man7/signal.7.html *) let signal_description_list = [ ("SIGHUP", ("POSIX.1-1990", Term, "Hangup detected on controlling terminal or death of controlling process")); ("SIGINT", ("POSIX.1-1990", Term, "Interrupt from keyboard")); ("SIGQUIT", ("POSIX.1-1990", Core, "Quit from keyboard")); ("SIGILL", ("POSIX.1-1990", Core, "Illegal Instruction")); ("SIGABRT", ("POSIX.1-1990", Core, "Abort signal from abort(3)")); ("SIGFPE", ("POSIX.1-1990", Core, "Floating point exception")); ("SIGKILL", ("POSIX.1-1990", Term, "Kill signal")); ("SIGSEGV", ("POSIX.1-1990", Core, "Invalid memory reference")); ("SIGPIPE", ("POSIX.1-1990", Term, "Broken pipe: write to pipe with no readers")); ("SIGALRM", ("POSIX.1-1990", Term, "Timer signal from alarm(2)")); ("SIGTERM", ("POSIX.1-1990", Term, "Termination signal")); ("SIGUSR1", ("POSIX.1-1990", Term, "User-defined signal 1")); ("SIGUSR2", ("POSIX.1-1990", Term, "User-defined signal 2")); ("SIGCHLD", ("POSIX.1-1990", Ign, "Child stopped or terminated")); ("SIGCONT", ("POSIX.1-1990", Cont, "Continue if stopped")); ("SIGSTOP", ("POSIX.1-1990", Stop, "Stop process")); ("SIGTSTP", ("POSIX.1-1990", Stop, "Stop typed at tty")); ("SIGTTIN", ("POSIX.1-1990", Stop, "tty input for background process")); ("SIGTTOU", ("POSIX.1-1990", Stop, "tty output for background process")); ("SIGBUS", ("POSIX.1-2001", Core, "Bus error (bad memory access)")); ("SIGPOLL", ("POSIX.1-2001", Term, "Pollable event (Sys V). Synonym for SIGIO")); ("SIGPROF", ("POSIX.1-2001", Term, "Profiling timer expired")); ("SIGSYS", ("POSIX.1-2001", Core, "Bad argument to routine (SVr4)")); ("SIGTRAP", ("POSIX.1-2001", Core, "Trace/breakpoint trap")); ("SIGURG", ("POSIX.1-2001", Ign, "Urgent condition on socket (4.2BSD)")); ("SIGVTALRM", ("POSIX.1-2001", Term, "Virtual alarm clock (4.2BSD)")); ("SIGXCPU", ("POSIX.1-2001", Core, "CPU time limit exceeded (4.2BSD)")); ("SIGXFSZ", ("POSIX.1-2001", Core, "File size limit exceeded (4.2BSD)")); ("SIGIOT", ("NOT-IN-POSIX", Core, "IOT trap. A synonym for SIGABRT")); ("SIGEMT", ("NOT-IN-POSIX", Term, "")); ("SIGSTKFLT", ("NOT-IN-POSIX", Term, "Stack fault on coprocessor (unused)")); ("SIGIO", ("NOT-IN-POSIX", Term, "I/O now possible (4.2BSD)")); ("SIGCLD", ("NOT-IN-POSIX", Ign, "A synonym for SIGCHLD")); ("SIGPWR", ("NOT-IN-POSIX", Term, "Power failure (System V)")); ("SIGINFO", ("NOT-IN-POSIX", Term, "A synonym for SIGPWR")); ("SIGLOST", ("NOT-IN-POSIX", Term, "File lock lost")); ("SIGWINCH", ("NOT-IN-POSIX", Ign, "Window resize signal (4.3BSD, Sun)")); ("SIGUNUSED", ("NOT-IN-POSIX", Core, "Synonymous with SIGSYS")); ("SIGRTMIN", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+1", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+2", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+3", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+4", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+5", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+6", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+7", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+8", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+9", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+10", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+11", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+12", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+13", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+14", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMIN+15", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-14", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-13", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-12", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-11", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-10", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-9", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-8", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-7", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-6", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-5", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-4", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-3", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-2", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX-1", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ("SIGRTMAX", ("POSIX.1-2001", Term, the_SIGRTMIN_and_SIGRTMAX_descr)); ];; (* A global structures for rapid access to signal informations: *) let name_of_signal = let module Map = MapExtra.Destructive.Int_map in let m = Map.create () in let () = List.iter (fun (i,n) -> Map.add i n m) signal_list in fun i -> Map.find i m let description_of_signal = let module Map = MapExtra.Destructive.String_map in let m = Map.create () in let () = List.iter (fun (i,n) -> Map.add i n m) signal_description_list in fun i -> Map.find i m (** Convert the signal in an integer as indicated by [kill -l] on a GNU/Linux. *) let int_of_signal = function | x when x=Sys.sigabrt -> 6 | x when x=Sys.sigalrm -> 14 | x when x=Sys.sigfpe -> 8 | x when x=Sys.sighup -> 1 | x when x=Sys.sigill -> 4 | x when x=Sys.sigint -> 2 | x when x=Sys.sigkill -> 9 | x when x=Sys.sigpipe -> 13 | x when x=Sys.sigquit -> 3 | x when x=Sys.sigsegv -> 11 | x when x=Sys.sigterm -> 15 | x when x=Sys.sigusr1 -> 10 | x when x=Sys.sigusr2 -> 12 | x when x=Sys.sigchld -> 17 | x when x=Sys.sigcont -> 18 | x when x=Sys.sigstop -> 19 | x when x=Sys.sigtstp -> 20 | x when x=Sys.sigttin -> 21 | x when x=Sys.sigttou -> 22 | x when x=Sys.sigvtalrm -> 26 | x when x=Sys.sigprof -> 27 | x -> x (** Convert the signal in a string as indicated by [kill -l] on a GNU/Linux. *) let name_of_signal = function | x when x=Sys.sigabrt -> "SIGABRT" | x when x=Sys.sigalrm -> "SIGALRM" | x when x=Sys.sigfpe -> "SIGFPE" | x when x=Sys.sighup -> "SIGHUP" | x when x=Sys.sigill -> "SIGILL" | x when x=Sys.sigint -> "SIGINT" | x when x=Sys.sigkill -> "SIGKILL" | x when x=Sys.sigpipe -> "SIGPIPE" | x when x=Sys.sigquit -> "SIGQUIT" | x when x=Sys.sigsegv -> "SIGSEGV" | x when x=Sys.sigterm -> "SIGTERM" | x when x=Sys.sigusr1 -> "SIGUSR1" | x when x=Sys.sigusr2 -> "SIGUSR2" | x when x=Sys.sigchld -> "SIGCHLD" | x when x=Sys.sigcont -> "SIGCONT" | x when x=Sys.sigstop -> "SIGSTOP" | x when x=Sys.sigtstp -> "SIGTSTP" | x when x=Sys.sigttin -> "SIGTTIN" | x when x=Sys.sigttou -> "SIGTTOU" | x when x=Sys.sigvtalrm -> "SIGVTALRM" | x when x=Sys.sigprof -> "SIGPROF" | x -> (try name_of_signal x with Not_found -> (string_of_int (int_of_signal x))) let signal_behavior i = let result = Sys.signal i Sys.Signal_default in let () = Sys.set_signal i result in result (* We don't synchronize with other threads in order to prevent possible (even if quite improbable) deadlocks. Actually there is a possible perverse situation: a thread may be interrupted by a signal exactly when it was printing using the module Log, and exactly during the short critical section of the ordinary mutex used to implement the recursive mutex used in Log... *) module Log = Ocamlbricks_log.Unprotected let fold_on_signals ?(except=[]) ?(caller="fold_on_signals") f s = let rec loop s i = if i > 64 then s else if i = 32 then loop s (i+2) else (* 32 and 33 are meaningless *) if List.mem i except then loop s (i+1) else let s' = try let b = signal_behavior i in f s i b with Sys_error _ -> let n = name_of_signal i in Log.printf "%s: skipping to apply the function to signal %2d (%s)\n" caller i n; s in loop s' (i+1) in loop s 1 let iter_on_signals ?except f = fold_on_signals ?except ~caller:"iter_on_signals" (fun () i b -> f i b) () let wrap_signal_receptions ?except ?also_ignored ?also_core_dumped wrapper = let simulated_handler_of_default_action = function | Ign when also_ignored<>None -> Some ignore | Term -> Some (fun i -> exit (128+(int_of_signal i))) | Core when also_core_dumped<>None -> Some (fun i -> Sys.set_signal i Sys.Signal_default; Unix.kill (Unix.getpid ()) i) | _ -> None in iter_on_signals ?except begin fun i behavior -> let signo = int_of_signal i in let name = name_of_signal signo in let (_, action, descr) = description_of_signal name in match behavior with | Sys.Signal_handle current_handler -> Sys.set_signal i (wrapper ~signo ~name ~descr ~current_handler) | Sys.Signal_ignore -> Sys.set_signal i (wrapper ~signo ~name ~descr ~current_handler:ignore) | Sys.Signal_default -> (match simulated_handler_of_default_action action with | None -> () | Some current_handler -> Sys.set_signal i (wrapper ~signo ~name ~descr ~current_handler) ) end let log_signal_reception ?except () = let wrapper ~signo ~name ~descr ~current_handler = Sys.Signal_handle (fun i -> Log.printf "Received signal %d (%s): %s\n" signo name descr; current_handler i) in wrap_signal_receptions ?except ~also_core_dumped:() ~also_ignored:() wrapper let description_of_name name = let (posix, action, descr) = description_of_signal name in (posix, (string_of_default_action action), descr) (* Redefined in order to have an integer as input and only strings in the result: *) let description_of_signal i = let signo = int_of_signal i in let name = name_of_signal signo in let (posix, action, descr) = description_of_signal name in (name, posix, (string_of_default_action action), descr) (* Redefined in order to remove the ?caller parameter: *) let fold_on_signals ?except f s = fold_on_signals ?except f s IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Test = struct (* May be tested from the shell: $ make test \<\<\<"SysExtra.Test.log_signal_reception () ;;" 2>/tmp/test.log $ grep Received /tmp/test.log *) let log_signal_reception () = iter_on_signals begin fun i b -> let _ = ThreadExtra.fork_with_tutor ~before_waiting:(fun ~pid -> Log.printf "Trying to send the signal No. %d to %d\n" i pid; ThreadExtra.delay 0.5; (* cannot be interrupted by a signal *) Unix.kill pid i) (fun () -> log_signal_reception (); Log.printf "In pause...\n"; Thread.delay 1.) () in ThreadExtra.delay 1.; Log.printf "=======================================\n"; () end end (* module Test *) ENDIF ocamlbricks-0.90+bzr456.orig/EXTRA/mutexExtra.mli0000644000175000017500000000552713175721005020470 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009, 2011 Jean-Vincent Loddo Copyright (C) 2011 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Mutex]. {b Example}: {[(* Extend the standard Mutex: *) module Mutex = MutexExtra.Extend (Mutex);; (* Use the function with_mutex: *) Mutex.with_mutex mutex (fun () -> ...);; (* Idem for recursive mutexes: *) module Recursive_mutex = MutexExtra.Extend (MutexExtra.Recursive_mutex) ;; (* Or equivalently, you can use a predefined functor application as shortcut: *) module Recursive_mutex = MutexExtra.Recursive ;; ]} *) module type Mutex_signature = sig type t val create : unit -> t val lock : t -> unit val unlock : t -> unit val try_lock : t -> bool end module type Basic_signature = sig include Mutex_signature val wait : Condition.t -> t -> unit end module type Extended_signature = sig include Basic_signature val status : t -> bool val with_mutex : ?verbose:unit -> t -> (unit -> 'a) -> 'a val apply_with_mutex : ?verbose:unit -> t -> ('a -> 'b) -> 'a -> 'b val with_mutex_and_guard : ?perform_in_critical_section_before_sleeping:(unit -> unit) -> condition:Condition.t -> guard:(unit->bool) -> t -> (unit->'a) -> 'a val apply_with_mutex_and_guard : ?perform_in_critical_section_before_sleeping:(unit -> unit) -> condition:Condition.t -> guard:(unit->bool) -> t -> ('a -> 'b) -> 'a -> 'b val signal_with_mutex : condition:Condition.t -> t -> unit val broadcast_with_mutex : condition:Condition.t -> t -> unit end module Extend : functor (M:Basic_signature) -> Extended_signature module EMutex : Extended_signature with type t = Mutex.t (* Extended standard mutexes *) module RMutex : Extended_signature (* Extended recursive mutexes *) (* Just a more explicit alias for EMutex: *) module Extended_Mutex : Extended_signature with type t = Mutex.t (* Just a more explicit alias for RMutex: *) module Recursive : Extended_signature module Just_give_me_an_apply_with_mutex : functor (M:sig end) -> sig val apply_with_mutex : ('a -> 'b) -> 'a -> 'b end ocamlbricks-0.90+bzr456.orig/EXTRA/threadExtra.ml0000644000175000017500000005273713175721005020431 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2011 2012 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the module [Thread] provided by the [threads] library. *) IFNDEF OCAML4_02_OR_LATER THEN let lazy_is_val = Lazy.lazy_is_val ELSE let lazy_is_val = Lazy.is_val ENDIF module Log = Ocamlbricks_log module ULog = Ocamlbricks_log.Unprotected (* for critical sections *) module Exit_function = struct include MutexExtra.Just_give_me_an_apply_with_mutex (struct end) (* The hash table will be really built on demand: *) let ht = lazy (Hashtbl.create 51) let at_exit thunk = let pid = Unix.getpid () in let id = Thread.id (Thread.self ()) in let key = (pid, id) in let protected_thunk () = try thunk () with _ -> () in let ht = Lazy.force ht in let action () = let exit_function = try Hashtbl.find ht key with Not_found -> (fun ()->()) in let exit_function = (fun () -> protected_thunk (); exit_function ()) in Hashtbl.replace ht key exit_function in apply_with_mutex action () let do_at_exit () = let pid = Unix.getpid () in let id = Thread.id (Thread.self ()) in let key = (pid, id) in let action () = if lazy_is_val ht then let ht = Lazy.force ht in begin try let exit_function = Hashtbl.find ht key in let () = exit_function () in ULog.printf "Thread Exiting: some thunks executed\n"; Hashtbl.remove ht key with Not_found -> ULog.printf "Thread Exiting: nothing to do\n" end else ULog.printf "Thread Exiting: nothing to do\n" in apply_with_mutex action () (* Register a main thread final action performing all remaining registered functions for the same process. Note that the main thread has the identifier 0 only for the main process. For the child processes the main thread identifier has the value of the father thread in the father process. For instance, a Unix.fork() called in the thread 1000.6 (1000 is the pid) could create a main thread like 1042.6. *) let () = let mrproper () = let pid = Unix.getpid () in let id = Thread.id (Thread.self ()) in let action () = if lazy_is_val ht then begin let ht = Lazy.force ht in let (actions, exo_actions) = (ref 0, ref 0) in (* Executes all thunks related to the *same* process: *) Hashtbl.iter (fun (pid', id') thunk -> if pid=pid' then begin incr actions; (if id<>id' then incr exo_actions); thunk () end) ht; Hashtbl.clear ht; if !actions = 0 then ULog.printf "Thread Exiting (main): nothing to do\n" else ULog.printf "Thread Exiting (main): %d thunk(s) executed (%d exogenous)\n" !actions ! exo_actions end else ULog.printf "Thread Exiting (main): nothing to do\n" in apply_with_mutex action () in (* Registering here, this action will be executed only by the main thread: *) Pervasives.at_exit mrproper end module Available_signals = struct (* We will use signals from SIGRTMIN (34) to SIGRTMAX (64) included: *) module Sem = Semaphore.Array_or (struct let dim = 64 - 34 + 1 end) (* For managing both the thread -> signal mapping and the thread -> thunk one: *) module Map = MapExtra.Destructive.Int_map let all_usable_signals = Array.to_list (Array.init 31 (fun i -> i+34)) (* The main structure of this module is an array of semaphores (with the "or" semantics). Each forked process must recreate its own fresh structure. *) module T = Stateful_modules.Process_private_thread_shared_variable (struct type t = (Semaphore.t array) * (int Map.t) let name = None let init () = let semaphores = Sem.create ~init:(Array.make Sem.dim 1) () in let mapping = Map.create () in (semaphores, mapping) end) module EMutex = MutexExtra.EMutex (* The secondary structure of this module is the container where threads may provide themselves a mean to kill them. *) module H = Stateful_modules.Process_private_thread_shared_variable (struct type t = (unit->unit) Map.t let name = None let init () = Map.create () end) let set_killable_with_thunk ?(who=(Thread.self ())) thunk = let mapping = H.extract () in let id = Thread.id who in let () = H.apply_with_mutex (Map.add id thunk) mapping in () let child_remove_thunk_for_killing_me_if_any () = let mapping = H.extract () in let id = Thread.id (Thread.self ()) in let () = H.apply_with_mutex (Map.remove id) mapping in () (* Called by the father: *) let father_acquire_signal_slot () = let (semaphores, mapping) = T.extract () in let (i,n) = Sem.p semaphores in (* n=1 *) i (* Called by the child: *) let child_take_possession_of_signal_slot i = let (semaphores, mapping) = T.extract () in let id = Thread.id (Thread.self ()) in let () = T.apply_with_mutex (Map.add id (i+34)) mapping in () let child_release_signal_slot i = let (semaphores, mapping) = T.extract () in let id = Thread.id (Thread.self ()) in let () = T.apply_with_mutex (Map.remove id) mapping in let () = Sem.v ~i ~n:1 semaphores in () let killall () = (* Looking in the primary structure: *) let (semaphores, mapping) = T.extract () in let pid = Unix.getpid () in let () = T.apply_with_mutex (Map.iter (fun _ s -> Unix.kill pid s)) mapping in (* Looking in the secondary structure: *) let mapping = H.extract () in let () = H.apply_with_mutex (Map.iter (fun _ thunk -> try thunk () with _ -> ())) mapping in () let id_kill_by_signal id = Log.printf1 "Attempting to kill the thread %d by signal...\n" id; let (semaphores, mapping) = T.extract () in let result = T.apply_with_mutex (fun () -> try let s = Map.find id mapping in let pid = Unix.getpid () in let () = Unix.kill pid s in true with Not_found -> false) () in result let id_kill_by_thunk id = Log.printf1 "Attempting to kill the thread %d by thunk...\n" id; let mapping = H.extract () in let result = H.apply_with_mutex (fun () -> try let thunk = Map.find id mapping in (try thunk (); true with _ -> false) with Not_found -> false) () in result let id_kill id = Log.printf1 "Attempting to kill the thread %d...\n" id; let result = (id_kill_by_signal id) || (id_kill_by_thunk id) in Log.printf2 "Thread %d killed: %b\n" id result; result let kill t = id_kill (Thread.id t) let killable () = let (semaphores, mapping) = T.extract () in let xs = T.apply_with_mutex Map.domain mapping in let mapping = H.extract () in let ys = H.apply_with_mutex Map.domain mapping in List.append xs ys let id_killer_by_signal id = let (semaphores, mapping) = T.extract () in let s = T.apply_with_mutex (fun () -> try Some (Map.find id mapping) with Not_found -> None) () in match s with | Some s -> let pid = Unix.getpid () in (fun () -> Unix.kill pid s) | None -> raise Not_found let id_killer_by_thunk id = let mapping = H.extract () in let thunk = H.apply_with_mutex (fun () -> try Some (Map.find id mapping) with Not_found -> None) () in match thunk with | Some thunk -> thunk | None -> raise Not_found (* The result of the partial application may be transmitted to another process: *) let id_killer id = let result = try id_killer_by_signal id with Not_found -> id_killer_by_thunk id in let pid = Unix.getpid () in Log.printf2 "Built a killer thunk able to kill %d.%d\n" pid id; result let killer t = id_killer (Thread.id t) let delayed_kill s t = ignore (Thread.create (fun () -> Thread.delay s; kill t) ()) let delayed_killall s = ignore (Thread.create (fun () -> Thread.delay s; killall ()) ()) let delayed_id_kill s id = ignore (Thread.create (fun () -> Thread.delay s; id_kill id) ()) exception Has_been_killed (* For the main thread only: register the action of killing all suspending sub-threads. This action will provoke the execution of at_exit() for each sub-thread. *) let () = (* ugly trick: *) let one_thread_has_been_started_at_least () = (Thread.id (Thread.create (fun () -> ()) ())) > 1 in Pervasives.at_exit (fun () -> if one_thread_has_been_started_at_least () then begin ULog.printf "Thread Exiting (main): killing all sub-threads...\n"; killall (); Thread.delay 0.5 (* Give to the sub-threads the time to perform their at_exit functions *) end else ULog.printf "Thread Exiting (main): no sub-threads have been created.\n" ) end (* module Available_signals *) (** Similar to [Thread.create] but the result is a triple [(t,k,s)] where [k] is a thunk able to kill the thread and [s] is the signal number used by the thunk. This number may be provided to an external process in order to kill the thread. In the same process the thunk should be sufficient for this purpose. Note that there are only 31 (64-34+1) possible threads per process that may run simultaneously with the capability of being killed. Thus, this call is blocking: the caller wait until a "signal slot" became available for the thread that will be created. *) let create_killable = let handler id s = let id' = Thread.id (Thread.self ()) in (if id <> id' then ULog.printf ~v:0 "Wrong behaviour: thread %d should be killed by signal #%d but I'm killed instead\n" id s); ULog.printf "Killed by signal #%d\n" s; raise Available_signals.Has_been_killed in fun f x -> (* The *father* thread executes the following lines: *) let i = Available_signals.father_acquire_signal_slot () in let s = 34 + i in let _ = Thread.sigmask Unix.SIG_BLOCK [s] in (* The *child* thread executes the following lines: *) let f' y = (* Bloc all signals except the owned: *) let _ = Thread.sigmask Unix.SIG_SETMASK Available_signals.all_usable_signals in let _ = Thread.sigmask Unix.SIG_UNBLOCK [s] in let id = Thread.id (Thread.self ()) in let previous_handler = Sys.signal s (Sys.Signal_handle (handler id)) in let () = Available_signals.child_take_possession_of_signal_slot i in Log.printf1 "Signal #%d reserved to be able to kill this thread\n" s; let final_actions () = (* The thread should make free the owned signal: *) (Sys.set_signal s previous_handler); Available_signals.child_release_signal_slot i; Available_signals.child_remove_thunk_for_killing_me_if_any (); Exit_function.do_at_exit () in try let result = f y in (final_actions ()); result with e -> begin (final_actions ()); Log.print_exn ~prefix:"Terminated by uncaught exception: " e; let () = Thread.exit () in (* Not really executed: *) raise e end in let thread = Thread.create f' x in thread (** Similar to [Thread.create] but you must call this function if you want to use [ThreadExtra.at_exit] in your thread. *) let create_non_killable f x = let final_actions () = Available_signals.child_remove_thunk_for_killing_me_if_any (); Exit_function.do_at_exit () in let f' y = try let result = f y in (final_actions ()); result with e -> begin (final_actions ()); Log.print_exn ~prefix:"Terminated by uncaught exception: " e; let () = Thread.exit () in (* Not really executed: *) raise e end in Thread.create f' x let create ?killable f x = match killable with | None -> create_non_killable f x | Some () -> create_killable f x module Waitpid_thread_standard_implementation = struct let rec waitpid_non_intr ?(wait_flags=[]) pid = try Either.Right (Unix.waitpid wait_flags pid) with | Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr ~wait_flags pid | e -> begin Log.printf1 "ThreadExtra.waitpid_non_intr: exception: %s\n" (Printexc.to_string e); Either.Left e; end let waitpid_thread ?killable ?(before_waiting=fun ~pid -> ()) ?(after_waiting=fun ~pid status -> ()) ?perform_when_suspended ?(fallback=fun ~pid e -> ()) ?do_not_kill_process_if_exit () = let tutor_behaviour = let process_alive = ref true in let tutor_preamble pid = Log.printf1 "Thread created for tutoring (waitpid-ing) process %d\n" pid; if (pid <= 0) || (do_not_kill_process_if_exit = Some ()) then () else Exit_function.at_exit (fun () -> if !process_alive then begin Log.printf1 "Killing (SIGTERM) tutored process %d...\n" pid; Unix.kill pid 15; end); () in let (perform_when_suspended, wait_flags) = match perform_when_suspended with | None -> (fun ~pid -> ()), None | Some f -> f, (Some [Unix.WUNTRACED]) in fun pid -> let () = tutor_preamble pid in let rec loop () = let () = before_waiting ~pid in match (waitpid_non_intr ?wait_flags pid) with | Either.Left e -> fallback ~pid e | Either.Right (_, Unix.WSTOPPED _) -> Log.printf1 "Tutored process %d stopped.\n" pid; let () = perform_when_suspended ~pid in loop () | Either.Right (_, status) -> Log.printf1 "Tutored process %d terminated.\n" pid; let () = process_alive := false in let () = after_waiting ~pid status in () in loop () in fun ~pid -> create ?killable tutor_behaviour pid end (* module Waitpid_thread_standard_implementation *) module Waitpid_thread_catching_resume_event = struct module Process = UnixExtra.Process let rec waitpid_non_intr ?(wait_flags=[]) pid = try Either.Right (Process.waitpid wait_flags pid) with | Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr ~wait_flags pid | e -> begin Log.printf1 "ThreadExtra.waitpid_non_intr (catching resume): exception: %s\n" (Printexc.to_string e); Either.Left e; end let waitpid_thread ?killable ?(before_waiting=fun ~pid -> ()) ?(after_waiting=fun ~pid status -> ()) ?perform_when_suspended ?perform_when_resumed ?(fallback=fun ~pid e -> ()) ?do_not_kill_process_if_exit () = let tutor_behaviour = let process_alive = ref true in let tutor_preamble pid = Log.printf1 "Thread created for tutoring (waitpid-ing) process %d\n" pid; if (pid <= 0) || (do_not_kill_process_if_exit = Some ()) then () else Exit_function.at_exit (fun () -> if !process_alive then begin ULog.printf "Killing (SIGTERM) tutored process %d...\n" pid; Unix.kill pid 15; end); () in let (perform_when_suspended, wait_flags1) = match perform_when_suspended with | None -> (fun ~pid -> ()), [] | Some f -> f, [Process.WUNTRACED] in let (perform_when_resumed, wait_flags2) = match perform_when_resumed with | None -> (fun ~pid -> ()), [] | Some f -> f, [Process.WCONTINUE] in let wait_flags = List.append (wait_flags1) (wait_flags2) in fun pid -> let () = tutor_preamble pid in let rec loop () = let () = before_waiting ~pid in match (waitpid_non_intr ~wait_flags pid) with | Either.Left e -> fallback ~pid e | Either.Right (_, Process.WSTOPPED _) -> Log.printf1 "Tutored process %d stopped.\n" pid; let () = perform_when_suspended ~pid in loop () | Either.Right (_, Process.WCONTINUED) -> Log.printf1 "Tutored process %d resumed.\n" pid; let () = perform_when_resumed ~pid in loop () | Either.Right (_, Process.WUNCHANGED) -> loop () | Either.Right (_, Process.WEXITED i) -> Log.printf1 "Tutored process %d terminated (exited).\n" pid; let () = process_alive := false in let () = after_waiting ~pid (Unix.WEXITED i) in () | Either.Right (_, Process.WSIGNALED i) -> Log.printf1 "Tutored process %d terminated (killed).\n" pid; let () = process_alive := false in let () = after_waiting ~pid (Unix.WSIGNALED i) in () in loop () in fun ~pid -> create ?killable tutor_behaviour pid end (* module Waitpid_thread_catching_resume_event *) (* Switch between the two implementation, according to the need of catching `resume' events: *) let waitpid_thread ?killable ?before_waiting ?after_waiting ?perform_when_suspended ?perform_when_resumed ?fallback ?do_not_kill_process_if_exit () = match perform_when_resumed with | None -> Waitpid_thread_standard_implementation.waitpid_thread ?killable ?before_waiting ?after_waiting ?perform_when_suspended ?fallback ?do_not_kill_process_if_exit () | Some perform_when_resumed -> Waitpid_thread_catching_resume_event.waitpid_thread ?killable ?before_waiting ?after_waiting ?perform_when_suspended ~perform_when_resumed ?fallback ?do_not_kill_process_if_exit () let fork_with_tutor ?killable ?before_waiting ?after_waiting ?perform_when_suspended ?perform_when_resumed ?fallback ?do_not_kill_process_if_exit f x = let tutor = waitpid_thread ?killable ?before_waiting ?after_waiting ?perform_when_suspended ?perform_when_resumed ?fallback ?do_not_kill_process_if_exit () in let pid = Unix.getpid () in let id = Thread.id (Thread.self ()) in let thread = match Unix.fork () with | 0 -> (* The child here: *) begin Log.printf2 "Process (fork) created by %d.%d\n" pid id; let _ = try f x with e -> Log.print_exn ~prefix:"Terminated by uncaught exception: " e; raise e in let () = exit 0 in raise Not_found (* not really executed, just to get around the type system *) end | child_pid -> (* The father here creates a process-tutor thread per child: *) tutor child_pid in thread ;; module Easy_API = struct (* Tutoring thread options: *) type options = { mutable killable : unit option; mutable before_waiting : (pid:int -> unit) option; mutable after_waiting : (pid:int -> Unix.process_status -> unit) option; mutable perform_when_suspended : (pid:int -> unit) option; mutable perform_when_resumed : (pid:int -> unit) option; mutable fallback : (pid:int -> exn -> unit) option; mutable do_not_kill_process_if_exit : unit option; } let make_defaults () = { killable = None; before_waiting = None; after_waiting = None; perform_when_suspended = None; perform_when_resumed = None; fallback = None; do_not_kill_process_if_exit = None; } let make_options ?enrich ?killable ?before_waiting ?after_waiting ?perform_when_suspended ?perform_when_resumed ?fallback ?do_not_kill_process_if_exit () = let t = match enrich with None -> make_defaults () | Some t -> t in let () = t.killable <- killable in let () = t.before_waiting <- before_waiting in let () = t.after_waiting <- after_waiting in let () = t.perform_when_suspended <- perform_when_suspended in let () = t.perform_when_resumed <- perform_when_resumed in let () = t.fallback <- fallback in let () = t.do_not_kill_process_if_exit <- do_not_kill_process_if_exit in t let apply_with_options ?options (f:?killable:unit -> ?before_waiting:(pid:int->unit) -> ?after_waiting:(pid:int-> Unix.process_status -> unit) -> ?perform_when_suspended:(pid:int -> unit) -> ?perform_when_resumed:(pid:int -> unit) -> ?fallback:(pid:int -> exn -> unit) -> ?do_not_kill_process_if_exit:unit -> 'a -> 'b) arg = match options with | None -> f arg | Some t -> let killable = t.killable in let before_waiting = t.before_waiting in let after_waiting = t.after_waiting in let perform_when_suspended = t.perform_when_suspended in let perform_when_resumed = t.perform_when_resumed in let fallback = t.fallback in let do_not_kill_process_if_exit = t.do_not_kill_process_if_exit in f ?killable ?before_waiting ?after_waiting ?perform_when_suspended ?perform_when_resumed ?fallback ?do_not_kill_process_if_exit arg let waitpid_thread ?options () = apply_with_options ?options (waitpid_thread) () let fork_with_tutor ?options f = apply_with_options ?options (fork_with_tutor) f end (* Easy_API *) (** The standard Thread.delay may be interrupted by signals 17, 23 26 and 28 on a GNU/Linux. This version is not interrupted because the [select] with the timeout is called in a distinct thread. *) let delay time = let t = Thread.create (fun () -> let _ = Thread.sigmask Unix.SIG_BLOCK [17;23;26;28] in Unix.select [] [] [] time) () in (* join is not interrupted: *) Thread.join t (* In order to render killall and kill directly accessible at this level: *) include Available_signals include Exit_function (* let at_exit = Exit_function.at_exit *) ocamlbricks-0.90+bzr456.orig/EXTRA/arrayExtra.mli0000644000175000017500000001525713175721005020445 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Array].*) type 'a t = 'a array val of_known_length_list : ?reversing:bool -> int -> 'a list -> 'a array val partition : ?min_size:int -> ('a -> int) -> 'a array -> 'a array array val partitioni : ?min_size:int -> (int -> 'a -> int) -> 'a array -> 'a array array val amass : ?group_no:int -> ?size:int -> 'a array -> 'a array array val group_by : ('a -> 'b * 'c) -> 'a array -> 'b array * ('b, 'c array) Hashtbl.t val flatten : 'a array array -> 'a array val sub : ?len:int -> 'a array -> int -> 'a array val int_seq : min:int -> max:int -> incr:int -> int array val float_seq : min:float -> max:float -> incr:float -> float array val is_sorted : ?compare:('a -> 'a -> int) -> 'a array -> bool val sorted_copy : ?compare:('a -> 'a -> int) -> 'a array -> 'a array val fast_sorted_copy : ?compare:('a -> 'a -> int) -> 'a array -> 'a array val sort_saving_positions : ?compare:('a -> 'a -> int) -> 'a array -> (int * 'a) array val sort_saving_permutation : ?compare:('a -> 'a -> int) -> 'a array -> (int array) * ('a array) val apply_permutation : int array -> 'a array -> 'a array val undo_permutation : int array -> 'a array -> 'a array val sort_in_the_same_way : ?compare:('a -> 'a -> int) -> 'a array -> 'b array list -> (int array) * ('a array) * (('b array) list) val for_all : (int -> 'a -> bool) -> 'a array -> bool val exists : (int -> 'a -> bool) -> 'a array -> bool val lexists : (int -> 'a -> bool) -> 'a array -> int option val rexists : (int -> 'a -> bool) -> 'a array -> int option val search : ('a -> bool) -> 'a array -> 'a option val searchi : ('a -> bool) -> 'a array -> (int * 'a) option val find : ('a -> bool) -> 'a array -> 'a val findi : ('a -> bool) -> 'a array -> (int * 'a) val search_longest_sequence : ?leftmost:unit -> ('a -> bool) -> 'a array -> (int * int) option val shared_property : ('a -> 'b) -> 'a array -> bool val random_permutation : 'a array -> 'a array val frequence : ('a -> bool) -> 'a array -> int * float val count : ('a -> bool) -> 'a array -> int val values_such_that : (int -> 'a -> bool) -> 'a array -> 'a list val indexes_such_that : (int -> 'a -> bool) -> 'a array -> int list val indexes_and_values_such_that : (int -> 'a -> bool) -> 'a array -> (int * 'a) list (* Computes j = max {i | v.(i) <= x }. The result is None if there are no lower bounds for {x} in the array. A result as Some(true,j) means that v.(j) = x, while Some(false,j) means v.(j) < x. *) val dichotomic_rightmost_le : ?compare:('a -> 'a -> int) -> ?a:int -> ?b:int -> 'a -> 'a array -> (bool * int) option (* Computes j = min {i | x <= v.(i) }. The result is None if there are no upper bounds for {x} in the array. A result as Some(true,j) means that v.(j) = x, while Some(false,j) means x < v.(j). *) val dichotomic_leftmost_ge : ?compare:('a -> 'a -> int) -> ?a:int -> ?b:int -> 'a -> 'a array -> (bool * int) option (* In the following function `dichotomic_*' the optional parameter ?unicity will be used to obtain better performances when there aren't duplicates in the array. *) (* --- *) val dichotomic_frame : ?compare:('a -> 'a -> int) -> ?a:int -> ?b:int -> ?unicity:unit -> 'a -> 'a array -> (int * int) option (* --- *) val dichotomic_rightmost_lt : ?compare:('a -> 'a -> int) -> ?a:int -> ?b:int -> ?unicity:unit -> 'a -> 'a array -> int option val dichotomic_leftmost_gt : ?compare:('a -> 'a -> int) -> ?a:int -> ?b:int -> ?unicity:unit -> 'a -> 'a array -> int option val for_all2 : (int -> 'a -> 'b -> bool) -> 'a array -> 'b array -> bool val exists2 : (int -> 'a -> 'b -> bool) -> 'a array -> 'b array -> bool val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit val iteri2 : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val mapi2 : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map_folding : ('s -> 'a -> 'b * 's) -> 's -> 'a array -> 'b array val mapi_folding : (int -> 's -> 'a -> 'b * 's) -> 's -> 'a array -> 'b array (* --- *) val map_fold : ('s -> 'a -> 'b) -> ('s -> 'a -> 's) -> 's -> 'a array -> 'b array * 's val mapi_fold : (int -> 's -> 'a -> 'b) -> (int -> 's -> 'a -> 's) -> 's -> 'a array -> 'b array * 's val fold_lefti : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a val fold_righti : (int -> 'a -> 'b -> 'b) -> 'a array -> 'b -> 'b val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c val fold_lefti2 : (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a val fold_righti2 : (int -> 'a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c val fold_binop : ('a -> 'a -> 'a) -> 'a array -> 'a val init2 : int -> (int -> 'a *'b) -> 'a array * 'b array val split : ('a * 'b) array -> 'a array * 'b array val combine : 'a array -> 'b array -> ('a * 'b) array val cut : lengths:int list -> 'a array -> 'a array list val max : ?gt:('a -> 'a -> bool) -> 'a array -> int * 'a val min : ?gt:('a -> 'a -> bool) -> 'a array -> int * 'a val best : ?choice:('a -> 'a -> 'a) -> 'a array -> int * 'a module Matrix : sig type 'a t = 'a array array val init : int -> int -> (int -> int -> 'a) -> 'a t val of_list : 'a list list -> 'a t val to_list : 'a t -> 'a list list val transpose : 'a t -> 'a t end (** {2 Printing} *) val printf : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string, unit, string) format -> 'a array -> unit val eprintf : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string, unit, string) format -> 'a array -> unit val sprintf : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string, unit, string) format -> 'a array -> string val to_string : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string) -> 'a array -> string ocamlbricks-0.90+bzr456.orig/EXTRA/pervasivesExtra.ml0000644000175000017500000001327713175721005021345 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Luca Saiu: initial version * - Jean-Vincent Loddo: functors for printers *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF type filename = string type length = int (** Round the float. By default the number of decimals is set to 3. *) let round ?(decimals=3) x = let k = 10. ** (float_of_int decimals) in (floor (x *. k +. 0.5)) /. k (** Multiply by [100.] then round. For instance, [percentage ~decimals:1 0.896531] returns [89.7]. *) let percentage ?(decimals=0) x = round ~decimals (x *. 100.) (** Convert the two integers into floats, divide them, multiply by [100.] and finally round. For instance, [percentage_fraction ~decimals:2 711 1013] returns [70.19]. *) let percentage_fraction ?decimals x y = percentage ?decimals ((float_of_int x) /. (float_of_int y)) (** For-based folder using float numbers. *) let for_float ?backward ~min ~max ~step f acc = let tollerance = step /. 2. in match backward with | None -> let max = max +. tollerance in let rec loop acc x = if x > max then acc else loop (f acc x) (x+.step) in loop acc min | Some () -> let min = min -. tollerance in let rec loop acc x = if x < min then acc else loop (f acc x) (x-.step) in loop acc min let for_float ?break ?backward ~min ~max ~step f acc = let tollerance = step /. 2. in match backward, break with | None, None -> let max = max +. tollerance in let rec loop acc x = if x > max then acc else loop (f acc x) (x+.step) in loop acc min | None, Some break -> let max = max +. tollerance in let rec loop acc x = if x > max || (break acc x) then acc else loop (f acc x) (x+.step) in loop acc min | Some (), None -> let min = min -. tollerance in let rec loop acc x = if x < min then acc else loop (f acc x) (x-.step) in loop acc min | Some (), Some break -> let min = min -. tollerance in let rec loop acc x = if x < min || (break acc x) then acc else loop (f acc x) (x-.step) in loop acc min (** For-based folder using int numbers. *) let for_int ?break ?backward ?(step=1) ~min ~max f acc = match backward, break with | None, None -> let rec loop acc x = if x > max then acc else loop (f acc x) (x+step) in loop acc min | None, Some break -> let rec loop acc x = if x > max || (break acc x) then acc else loop (f acc x) (x+step) in loop acc min | Some (), None -> let rec loop acc x = if x < min then acc else loop (f acc x) (x-step) in loop acc min | Some (), Some break -> let rec loop acc x = if x < min || (break acc x) then acc else loop (f acc x) (x-step) in loop acc min let get_first_line_of_file filename = try let ch = open_in filename in let line = input_line ch in let () = close_in ch in Some line with _ -> None let get_first_lines_of_file filename n = try let ch = open_in filename in let rec loop k acc = if k=0 then List.rev acc else try let line = input_line ch in loop (k-1) (line::acc) with _ -> List.rev acc in let result = loop n [] in let () = close_in ch in result with _ -> [] let get_first_chars_of_file filename n = try let ch = open_in filename in let rec loop k acc = if k=0 then List.rev acc else try let line = input_char ch in loop (k-1) (line::acc) with _ -> List.rev acc in let result = loop n [] in let () = close_in ch in result with _ -> [] let with_open_in ~filename mtdh = let in_channel = open_in filename in let length = in_channel_length (in_channel) in let result = mtdh in_channel length in close_in in_channel; result let with_open_in_bin ~filename mtdh = let in_channel = open_in_bin filename in let length = in_channel_length (in_channel) in let result = mtdh in_channel length in close_in in_channel; result let with_open_out ?(perm=0o644) ~filename mtdh = let file_exists = Sys.file_exists filename in let out_channel = open_out filename in let result = mtdh out_channel in close_out out_channel; if not file_exists then Unix.chmod filename perm else (); result let with_open_out_bin ?(perm=0o644) ~filename mtdh = let file_exists = Sys.file_exists filename in let out_channel = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0 filename in let result = mtdh out_channel in close_out out_channel; if not file_exists then Unix.chmod filename perm else (); result let get_file_content ~filename = with_open_in_bin ~filename (fun in_channel length -> let s = Bytes.create length in really_input in_channel s 0 length; s) let put_file_content ?perm ~filename content = with_open_out_bin ?perm ~filename (fun out_channel -> output_string out_channel content) ocamlbricks-0.90+bzr456.orig/EXTRA/mutexExtra.ml0000644000175000017500000001630513175721005020313 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009, 2011 Jean-Vincent Loddo Copyright (C) 2009 Luca Saiu Copyright (C) 2009, 2011 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Jean-Vincent Loddo: complete rewriting (2011), functorization (2009) * - Luca Saiu: initial version *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../EXTRA/mutexExtra.mli" (** Make the extra definitions for a module with a `Basic_signature': *) module Extend (Mutex : Basic_signature) = struct include Mutex (** Execute thunk in a synchronized block, and return the value returned by the thunk. If executing thunk raises an exception the same exception is propagated, after correctly unlocking the mutex. *) let with_mutex ?verbose mutex thunk = Mutex.lock mutex; try let result = thunk () in Mutex.unlock mutex; result with e -> begin Mutex.unlock mutex; if verbose = Some () then (Printf.eprintf "MutexExtra.Extend.with_mutex: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)) else (); raise e; end (** Similar to [with_mutex]: the argument will be given to the function in a synchronized block. *) let apply_with_mutex ?verbose mutex f x = let thunk () = f x in with_mutex ?verbose mutex thunk (** Similar to try_lock but the mutex is not locked (useful for monitoring). In this quick-and-easy implementation we call first try_lock, then unlock if necessary: *) let status mutex = let result = try_lock mutex in if result then unlock mutex else (); result let with_mutex_and_guard ?(perform_in_critical_section_before_sleeping=fun () -> ()) ~(condition:Condition.t) ~guard mutex action = with_mutex mutex (fun () -> if guard () then action () (* and nothing else *) else begin perform_in_critical_section_before_sleeping (); Mutex.wait (condition) mutex; (* When someone signal (or broadcast) on `condition', test the condition again: *) while not (guard ()) do perform_in_critical_section_before_sleeping (); Mutex.wait (condition) mutex done; action () end ) let apply_with_mutex_and_guard ?perform_in_critical_section_before_sleeping ~(condition:Condition.t) ~guard mutex f x = let thunk () = f x in with_mutex_and_guard ?perform_in_critical_section_before_sleeping ~condition ~guard mutex thunk let signal_with_mutex ~condition mutex = with_mutex mutex (fun () -> Condition.signal condition) let broadcast_with_mutex ~condition mutex = with_mutex mutex (fun () -> Condition.broadcast condition) end (* module Extend *) (** Extended standard mutexes. *) module EMutex = Extend(struct include Mutex let wait = Condition.wait end) (** A simple implementation of recursive mutexes inspired by Luca's version and by a (bugged?) version found in the project http://batteries.forge.ocamlcore.org/. In my opinion there's a bug in the batteries' version that I think fixed here using a condition variable instead of a second mutex -- Jean-Vincent. *) module Recursive_basic (*: Basic_signature *) = struct type owner = { thread_id : int; (** The thread identifier of the owner *) mutable lock_no : int; (** Number of lock performed by the owner (lock_no >= 1) *) } type t = { waiting_condition : Condition.t; (** The condition variable used for passive waiting *) owner_mutex : Mutex.t; (** The mutex used to protect the access to the owner fields *) mutable owner : owner option; } let create () = { waiting_condition = Condition.create (); owner_mutex = Mutex.create (); owner = None } let lock t = let id = Thread.id (Thread.self ()) in EMutex.with_mutex t.owner_mutex (fun () -> match t.owner with | None -> t.owner <- Some {thread_id = id; lock_no = 1} | Some x when x.thread_id = id -> x.lock_no <- x.lock_no + 1 | Some x -> begin while not (t.owner = None) do Condition.wait t.waiting_condition t.owner_mutex done; t.owner <- Some {thread_id = id; lock_no = 1}; end ) let try_lock t = let id = Thread.id (Thread.self ()) in EMutex.with_mutex t.owner_mutex (fun () -> match t.owner with | None -> t.owner <- Some {thread_id = id; lock_no = 1}; true | Some x when x.thread_id = id -> x.lock_no <- x.lock_no + 1; true | Some x -> false ) let unlock t = let id = Thread.id (Thread.self ()) in EMutex.with_mutex t.owner_mutex (fun () -> match t.owner with | Some x when x.thread_id = id -> if x.lock_no > 1 then x.lock_no <- x.lock_no - 1 else begin t.owner <- None; (Condition.signal t.waiting_condition); end | _ -> invalid_arg "Trying to unlock a not owned recursive mutex" ) let wait (external_condition:Condition.t) t = let id = Thread.id (Thread.self ()) in EMutex.with_mutex t.owner_mutex (fun () -> match t.owner with | Some x when x.thread_id = id -> let previous_lock_no = x.lock_no in (* We simulate an unlock: *) t.owner <- None; (Condition.signal t.waiting_condition); (* Now wait on the external condition: *) Condition.wait (external_condition) t.owner_mutex; (* Someone has signaled on `condition'. Now we simulate a lock with the previous lock_no: *) while not (t.owner = None) do Condition.wait t.waiting_condition t.owner_mutex done; t.owner <- Some {thread_id = id; lock_no = previous_lock_no}; | _ -> invalid_arg "Trying to suspend on a not owned recursive mutex" ) (* More efficient implementation (see comment above about Extend.status): *) let status t = let id = lazy (Thread.id (Thread.self ())) in EMutex.with_mutex t.owner_mutex (fun () -> match t.owner with | None -> true | Some x when x.thread_id = (Lazy.force id) -> true | Some x -> false ) end (* Recursive_basic *) (** Extended recursive mutexes. *) module RMutex = struct include Extend(Recursive_basic) (* Redefined for efficiency: *) let status = Recursive_basic.status end (* Aliases: *) module Extended_Mutex = EMutex module Recursive = RMutex (** Usage: {[ include MutexExtra.RMutex.Just_give_me_an_apply_with_mutex (struct end) ]} *) module Just_give_me_an_apply_with_mutex (M:sig end) = struct let mutex = RMutex.create () let apply_with_mutex f x = RMutex.apply_with_mutex mutex f x end ocamlbricks-0.90+bzr456.orig/EXTRA/setExtra.mli0000644000175000017500000000652113175721005020114 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for (and instances of) the standard module [Set]. *) module type S = sig type elt type t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t val copy : t -> t val of_list : ?acc:t -> elt list -> t val of_lists : elt list list -> t val to_list : ?acc:elt list -> ?reverse:bool -> t -> elt list val uniq : elt list -> elt list end module Extend : functor (M : Set.S) -> S with type elt = M.elt and type t = M.t module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t module String_set : S with type elt = string module Int_set : S with type elt = int module Destructive : sig module type S = sig type elt type t val create : unit -> t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> unit val singleton : elt -> t val remove : elt -> t -> unit val union : t -> t -> unit val inter : t -> t -> unit val diff : t -> t -> unit val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> unit val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t val copy : t -> t val of_list : ?acc:t -> elt list -> t val to_list : ?acc:elt list -> ?reverse:bool -> t -> elt list end module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t module String_set : S with type elt = string module Int_set : S with type elt = int end (* Destructive *)ocamlbricks-0.90+bzr456.orig/EXTRA/pervasivesExtra.mli0000644000175000017500000000412613175721005021507 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Pervasives]. *) type filename = string type length = int val round : ?decimals:int (* 3 *) -> float -> float val percentage : ?decimals:int (* 0 *) -> float -> float val percentage_fraction : ?decimals:int (* 0 *) -> int -> int -> float val for_float : ?break:('a -> float -> bool) -> ?backward:unit -> min:float -> max:float -> step:float -> ('a -> float -> 'a) -> 'a -> 'a val for_int : ?break:('a -> int -> bool) -> ?backward:unit -> ?step:int -> min:int -> max:int -> ('a -> int -> 'a) -> 'a -> 'a (** The result on empty or non-existent files is None. *) val get_first_line_of_file : string -> string option (** The result on empty or non-existent files is the empty list. *) val get_first_lines_of_file : filename -> int -> string list (** The result on empty or non-existent files is the empty list. *) val get_first_chars_of_file : filename -> int -> char list val with_open_in : filename:string -> (in_channel -> length -> 'a) -> 'a val with_open_in_bin : filename:string -> (in_channel -> length -> 'a) -> 'a val with_open_out : ?perm:int -> filename:string -> (out_channel -> 'a) -> 'a val with_open_out_bin : ?perm:int -> filename:string -> (out_channel -> 'a) -> 'a val get_file_content : filename:string -> string val put_file_content : ?perm:int -> filename:string -> string -> unit ocamlbricks-0.90+bzr456.orig/EXTRA/stringExtra.ml0000644000175000017500000006665013175721005020467 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007-2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF (** The type of the standard [String.blit]. *) type blit_function = string -> int -> string -> int -> int -> unit (** Make a blit function that uses the argument [~(perform:char->int->unit)] to perform an action for any scanned character. The first argument of [perform] is the character that will be copied, the second argument is the index in the target string. {b Example}: {[# let perform c i = Printf.eprintf "Copying character %c at position %d\n" c i in let s = from_file ~blit:(blitting ~perform) "/etc/fstab" in ... ]} *) let blitting ~(perform:char->int->unit) : blit_function = fun s1 ofs1 s2 ofs2 len -> if len < 0 || ofs1 < 0 || ofs1 > String.length s1 - len || ofs2 < 0 || ofs2 > String.length s2 - len then invalid_arg "String.blitting" else let ofs1=ref ofs1 in let ofs2=ref ofs2 in for i=1 to len do let c = s1.[!ofs1] in let i = !ofs2 in (perform c i); (Bytes.set s2 i c); incr ofs1; incr ofs2; done (** Import the content of the [Unix] file descriptor. The optional [?(blit=String.blit)] allows to perform some operations during the copy of characters (see the function {!StringExtra.blitting}). *) let from_descr ?(blit:blit_function=String.blit) (fd:Unix.file_descr) : string = let q = Queue.create () in let buffer_size = 8192 in let buff = Bytes.create buffer_size in let rec loop1 acc_n = begin let n = (Unix.read fd buff 0 buffer_size) in if (n=0) then acc_n else ((Queue.push ((String.sub buff 0 n),n) q); loop1 (acc_n + n)) end in let dst_size = loop1 0 in let dst = Bytes.create dst_size in let rec loop2 dstoff = if dstoff>=dst_size then () else begin let (src,src_size) = Queue.take q in (blit src 0 dst dstoff src_size); loop2 (dstoff+src_size) end in (loop2 0); dst (** Similar to {!StringExtra.from_descr} but the user provides the file name instead of the file descriptor. *) let from_file ?(blit:blit_function=String.blit) (filename:string) : string = let fd = (Unix.openfile filename [Unix.O_RDONLY;Unix.O_RSYNC] 0o640) in let result = from_descr ~blit fd in (Unix.close fd); result (** Similar to {!StringExtra.from_descr} but the user provides the [Pervasives.in_channel] instead of the file descriptor. *) let from_channel ?(blit:blit_function=String.blit) in_channel : string = from_descr ~blit (Unix.descr_of_in_channel in_channel) (** Make a copy of a string performing an action for any scanned character. *) let from_string ~(perform:char->int->unit) (src:string) : string = let len = String.length src in let dst = Bytes.create len in let blit = blitting ~perform in (blit src 0 dst 0 len); dst (** [nth_index_from s n c nth] return the index of the [nth] occurrence of the character [c] searching in [s] from the offset [n]. Raise [Not_found] if there isn't a sufficient number of occurrences. {b Example}: {[# nth_index_from "@123@567@" 0 '@' 2;; : int = 4 ]}*) let rec nth_index_from = let rec lloop s offset c k = if k=0 then offset else (* degenere *) if k=1 then String.index_from s offset c else let offset' = String.index_from s offset c in lloop s (offset'+1) c (k-1) in fun s n c k -> if k<0 then nth_rindex_from s n c (-k) else lloop s n c k (** As [nth_index_from] but searching from the {e right} to the {e left} side. *) and nth_rindex_from = let rec rloop s offset c k = if k=0 then offset else (* degenere *) if k=1 then String.rindex_from s offset c else let offset' = String.rindex_from s offset c in rloop s (offset'-1) c (k-1) in fun s n c k -> if k<0 then nth_index_from s n c (-k) else rloop s n c k (** As [nth_index_from] but searching from the beginning of the string (offset [0]). *) let nth_index s = nth_index_from s 0 (** As [nth_rindex_from] but searching from the end of the string. *) let nth_rindex s = nth_rindex_from s ((String.length s)-1) (** Similar to the standard [List.for_all], considering a string as a list of characters. *) let for_all p s = let l = String.length s in let rec loop i = if i>=l then true else p s.[i] && loop (i+1) in loop 0 (** Similar to {!StringExtra.for_all} but the predicate needs also the index. *) let for_all_i p s = let l = String.length s in let rec loop i = if i>=l then true else p i s.[i] && loop (i+1) in loop 0 (** Similar to the standard [List.exists], considering a string as a list of characters. *) let exists p s = let l = String.length s in let rec loop i = if i>=l then false else p s.[i] || loop (i+1) in loop 0 (** Similar to {!StringExtra.exists} but the predicate needs also the index. *) let exists_i p s = let l = String.length s in let rec loop i = if i>=l then false else p i s.[i] || loop (i+1) in loop 0 (** As the function {!StringExtra.exists}, but provides the index that verifies the predicate. *) let lexists p s = let l = String.length s in let rec loop i = if i>=l then None else if p s.[i] then (Some i) else loop (i+1) in loop 0 (** As the function [lexists], but searching from the right side. *) let rexists p s = let l = String.length s in let rec loop i = if i<0 then None else if p s.[i] then (Some i) else loop (i-1) in loop (l-1) ;; let is_prefix x y = try for_all_i (fun i c -> c = y.[i]) x with (Invalid_argument _) -> false ;; (** [tail s i] return the substring from the index [i] (included) to the end of [s]. Raise [Invalid_argument "tail"] if the index is out of the string bounds. {b Example}: {[# tail "azerty" 2;; : string = "erty" ]} *) let tail s i = try String.sub s i ((String.length s)-i) with Invalid_argument _ -> raise (Invalid_argument "tail") (** [head s i] return the substring from the beginning of [s] to the index [i] included. Raise [Invalid_argument "head"] if the index is out of the string bounds. {b Example}: {[# head "azerty" 2;; : string = "aze" # head "azerty" 0 ;; : string = "a" ]} *) let head s i = try String.sub s 0 (i+1) with Invalid_argument _ -> raise (Invalid_argument "head") (** [frame s c nth1 nth2] return the substring of [s] delimited by the [nth1] and the [nth2] occurrence of the character [c]. Raise [Not_found] if the number of occurrences is lesser than [nth1]. Raise [Invalid_argument "frame"] if [nth1] is greater than [nth2]. {b Example}: {[# frame "\@xxx\@yyy\@zzz\@" '@' 1 3 ;; : string = "\@xxx\@yyy\@" ]}*) let frame s c nth1 nth2 = if nth2 (String.length s)-1 in String.sub s offset1 (offset2-offset1+1) (** As [frame] but raise [Not_found] also if the number of occurrences is lesser than [nth2]. *) let frame_strict s c nth1 nth2 = if nth2 0 in String.sub s offset2 (offset1-offset2+1) (** As [rframe] but raise [Not_found] also if the number of occurrences is lesser than [nth2]. *) let rframe_strict s c nth1 nth2 = if nth2 acc in fun s c -> loop s c 0 0 (** Note that the last index is (-1) when the character is not found. *) let count_and_last_index = let rec loop s c i acc last_index = try let i = (String.index_from s i c) in loop s c (i+1) (acc+1) i with Not_found -> (acc,last_index) in fun s c -> loop s c 0 0 (-1) (** Note that the last two indexes may be (-1) if there isn't a sufficient number of occurrences. *) let count_and_last_two_indexes = let rec loop s c i acc last_index penultimate = try let i = (String.index_from s i c) in loop s c (i+1) (acc+1) i last_index with Not_found -> (acc,last_index,penultimate) in fun s c -> loop s c 0 0 (-1) (-1) (** [not_blank] stands for not [' '], not ['\t'] and not ['\n'] *) let not_blank = (fun c -> (c<>' ') && (c<>'\t') && (c<>'\n')) (** Strip the left side of the string with the predicate {!StringExtra.not_blank} *) let lstrip s = match lexists not_blank s with | None -> "" | Some i -> String.sub s i (((String.length s))-i) (** Strip the right side of the string with the predicate {!StringExtra.not_blank} *) let rstrip s = match rexists not_blank s with | None -> "" | Some i -> String.sub s 0 (i+1) (** Strip the both sides of the string with the predicate {!StringExtra.not_blank} *) let strip s = match (lexists not_blank s) with | None -> "" | Some i -> (match (rexists not_blank s) with | Some j -> String.sub s i (j-i+1) | None -> assert false ) (** Remove from the input string the last chars in the set [['\n','\t',' ']]. Similar to the [rstrip] {e Python} function. Example: {[# chop "hell o \t\n";; : string = "hell o"]} *) let rec chop x = let l = (String.length x) in if (l=0) then x else begin let last = (String.sub x (l-1) 1) in match last with | "\n" | " " | "\t" -> chop (String.sub x 0 (l-1)) | _ -> x end (** Similar to [cut ~n:1] but returns the list of {e characters} (instead of strings) of the input string. {b Example}: {[# to_charlist "aaabbc";; : char list = ['a'; 'a'; 'a'; 'b'; 'b'; 'c']]}*) let to_charlist (s:string) = let l = String.length s in let rec loop s l = if l=0 then [] else let l' = (l-1) in (s.[0])::(loop (String.sub s 1 l') l') in loop s l (** Some efficient char list operations (assemble/disassemble). *) module Charlist = struct (** Fold a char list into a string. *) let assemble (xs:char list) : string = let n = List.length xs in let s = Bytes.create n in let rec loop i = function | [] -> () | x::xs -> (Bytes.set s i x); loop (i+1) xs in (loop 0 xs); s (** Disassemble (split) the string and return the reversed list of its characters. {b Example}: {[# disassemble_reversing "abcd" ;; : char list = ['d'; 'c'; 'b'; 'a'] ]} *) let disassemble_reversing ?(acc=[]) (s:string) : char list = let n = String.length s in let rec loop acc i = if i>=n then acc else loop ((s.[i])::acc) (i+1) in loop acc 0 (** Assemble a list of char into a string reversing the order. {b Example}: {[# assemble_reversing ['a';'b';'c';'d'] ;; : string = "dcba" ]} *) let assemble_reversing ?length (xs:char list) : string = let n = match length with None -> List.length xs | Some x->x in let s = String.make n ' ' in let rec loop i = function | [] -> () | x::xs -> (Bytes.set s i x); loop (i-1) xs in (loop (n-1) xs); s end (** Convert a list of chars in a string. {[# of_charlist ['h';'e';'l';'l';'o'];; : string = "hello" ]}*) let of_charlist = Charlist.assemble (** [expand f s] expand characters of [s] with the string provided by [f], if any, or leave the character unchanged if [f] returns [None]. {b Example}: {[ # expand (function '>' -> Some ">" | _ -> None ) "int -> bool" ;; : string = "int -> bool" ]}*) let expand (f:char -> string option) s = let n = String.length s in let xs = to_charlist s in let (ys,n) = List.fold_left (fun (ys,n) c -> match f c with | None -> ((c::ys),n) | Some x -> ((Charlist.disassemble_reversing ~acc:ys x),(n + (String.length x) - 1)) ) ([],n) xs in Charlist.assemble_reversing ~length:n ys (** Similar to [Array.iteri]. *) let iteri f s = let n = String.length s in for i = 0 to n-1 do f i (String.unsafe_get s i) done (** Similar to [Array.init]. {b Example}: {[# init 10 (fun i->if i<3 then 'a' else 'b') ;; : string = "aaabbbbbbb" ]} *) let init n f = let s = Bytes.create n in for i = 0 to n-1 do (Bytes.set s i (f i)) done; s (** Similar to [Array.map]. {b Example}: {[# map (fun x -> if x='a' then 'A' else x) "aaabbbac" ;; : string = "AAAbbbAc" ]} *) let map (f:char -> char) s = let n = String.length s in init n (fun i -> f (String.unsafe_get s i)) (** Similar to [Array.mapi]. {b Example}: {[# mapi (fun i x -> if x='a' && i<3 then 'A' else x) "aaabbbac" ;; : string = "AAAbbbac" ]} *) let mapi f s = let n = String.length s in init n (fun i -> f i (String.unsafe_get s i)) let iter2 f a b = iteri (fun i a -> f a (String.unsafe_get b i)) a let iteri2 f a b = iteri (fun i a -> f i a (String.unsafe_get b i)) a let map2 f a b = mapi (fun i a -> f a (String.unsafe_get b i)) a let mapi2 f a b = mapi (fun i a -> f i a (String.unsafe_get b i)) a (** Similar to the Unix command [tr]. The call [tr a b s] returns a copy of [s] where all occurrences of the character [a] have been replaced with [b]. *) let tr a b = map (fun x -> if x=a then b else x) ;; let fold_left f y0 s = let l = String.length s in let rec loop acc i = if i>=l then acc else let acc = f acc (String.unsafe_get s i) in loop acc (i+1) in loop y0 0 let fold_lefti f y0 s = let l = String.length s in let rec loop acc i = if i>=l then acc else let acc = f i acc (String.unsafe_get s i) in loop acc (i+1) in loop y0 0 let fold_righti f s y0 = let l = String.length s in let rec loop acc i = if i<0 then acc else let acc = f i (String.unsafe_get s i) acc in loop acc (i-1) in loop y0 (l-1) let fold_right f s y0 = let l = String.length s in let rec loop acc i = if i<0 then acc else let acc = f (String.unsafe_get s i) acc in loop acc (i-1) in loop y0 (l-1) let fold_left2 f s0 xs ys = fold_lefti (fun i s x -> f s x ys.(i)) s0 xs let fold_right2 f xs ys s0 = fold_righti (fun i x s -> f x ys.(i) s) xs s0 let fold_lefti2 f s0 xs ys = fold_lefti (fun i s x -> f i s x ys.(i)) s0 xs let fold_righti2 f xs ys s0 = fold_righti (fun i x s -> f i x ys.(i) s) xs s0 (** Split a string into a list of strings containing each one [n] characters of the input string (by default [n=1]). {b Examples}: {[# cut "aabbc";; : string list = ["a"; "a"; "b"; "b"; "c"] # cut ~n:2 "aabbc";; : string list = ["aa"; "bb"; "c"] # cut ~n:3 "aabbc";; : string list = ["aab"; "bc"] ]} *) let cut ?(n:int=1) (s:string) = let l = String.length s in let rec loop s l = if l=0 then [] else if l if (s="") then [] else [s] (** Split a string into a string list using a list of blanks as word separators. By default blanks are [['\t';' ']] and will be squeezed. *) let split_squeezing_blanks ?(blanks=['\t';' ']) (s:string) : string list = let xs = Charlist.disassemble_reversing s in let push_if_not_empty x l = if x=[] then l else (x::l) in let rec loop previous_blank acc1 acc2 = function | [] -> (push_if_not_empty acc1 acc2) | b ::xs when (List.mem b blanks) -> if previous_blank then loop true acc1 acc2 xs else loop true [] (push_if_not_empty acc1 acc2) xs | x ::xs -> loop false (x::acc1) acc2 xs in let xs = List.map Charlist.assemble (loop false [] [] xs) in xs (** Catenate a list of strings in an efficient way: the target string is created once (not as happen with a fold of [^]). The optional [?(blit=String.blit)] allows to perform some operations during the copy of characters (see the function {!StringExtra.blitting}). *) let concat ?(blit:blit_function=String.blit) xs = let len = List.fold_left (fun k s -> k+(String.length s)) 0 xs in let dst = Bytes.create len in let _ = List.fold_left (fun k src -> let l=(String.length src) in (blit src 0 dst k l); (k+l)) 0 xs in dst (** Remove all occurrences of a character from a string. *) let rm d s = concat (split ~d s) ;; (** Quote a string using a prefix [l] (by default [l="'"]) and a suffix [r] (by default [r="'"]). *) let quote ?(l="'") ?(r="'") (x:string) = String.concat "" [l;x;r] (** Assemble a string with a prefix and a suffix but only if it is {b not} empty, else return the empty string ignoring the given prefix and suffix. *) let assemble_if_not_empty ~prefix ~suffix x = if (x="") then "" else (String.concat "" [prefix;x;suffix]) (** [map_concat f l] maps the function [f] on the list [l] then merge the result with the separator ([sep=" "] by default). *) let map_concat ?(sep=" ") f l = String.concat sep (List.map f l) (** Merge fields with a separator. {b Example}: {[# merge_fields "/" [2;4] ["aaa";"bbb";"ccc";"ddd";"eee"] ;; : string = "ccc/eee" ]}*) let rec merge_fields sep (fieldlist:int list) (l:string list) = let l'=(ListExtra.select l fieldlist) in (String.concat sep l') (** Convert a string in a [line] just adding a newline {b if needed}. The function {!StringExtra.chop} may be used as inverse. {b Example}: {[# ensure_cr_at_end "hello";; : string = "hello\n" # ensure_cr_at_end "hello\n";; : string = "hello\n"]}*) let ensure_cr_at_end x = if x="" then "\n" else (* continue *) let l = (String.length x) in let last = (String.sub x (l-1) 1) in match last with "\n" -> x | _ -> x^"\n" type word = string (** Converting raw text to list of strings and vice-versa. A raw text is simply a (may be big) string, i.e. a sequence of lines collected in a unique string, where each line terminates with a newline ['\n']. The last line in the text may not terminate with a newline. *) module Text = struct (** In this context, a line is not structured, it's a flatten string. *) type line = string (** A (line structured) text is a {b list} of strings. *) type t = line list (** Convert a string list in a raw text. Each string in the input list is treated by the function [ensure_cr_at_end] in order to add a newline if needed, then the list is folded by a simple catenation ([^]). If the input list is empty, the result is the empty string. {b Examples}: {[# Text.to_string ["AAA";"BBB";"CCC"];; : string = "AAA\nBBB\nCCC\n" # Text.to_string ["AAA";"BBB\n";"CCC"];; : string = "AAA\nBBB\nCCC\n" # Text.to_string ["AAA";"BBB\n\n";"CCC"];; : string = "AAA\nBBB\n\nCCC\n"]}*) let to_string (sl : string list) : string = let ll = List.map ensure_cr_at_end sl in String.concat "" ll (** Convert a raw text in a structured text (a string list). This function is simply an alias for [split ~d:'\n']. {b Examples}: {[# Text.of_string (UnixExtra.cat "/etc/fstab") ;; : string list = ["/dev/sda1 / reiserfs acl,user_xattr 1 1"; "/dev/sda3 swap swap defaults 0 0"; "/dev/sda4 /home reiserfs acl,user_xattr 1 1"; "proc /proc proc defaults 0 0"; "/dev/fd0 /media/floppy auto noauto,user,sync 0 0"] # Text.of_string (Unix.shell "echo aaa; echo; echo bbb");; : string list = ["aaa"; "bbb"] # Text.of_string ~do_not_squeeze:() (Unix.shell "echo aaa; echo; echo bbb");; : string list = ["aaa"; ""; "bbb"] ]} *) let of_string = (split ~d:'\n') (** Grep on string lists: only strings matching the pattern are selected. The optional arguments [~before] and [~after] correspond to the options [-B] and [-A] of the homonymous Unix command. {b Examples}: {[# grep "[0-9]" ["aa";"bb";"c8";"dd";"1e"] ;; : string list = ["c8"; "1e"] # grep "[0-9]$" ["aa";"bb";"c8";"dd";"1e"] ;; : string list = ["c8"] # "ls" => ( Sys.run || fst || String.to_list || grep ".*mli$" ) ;; : string list = ["foo.mli"; "bar.mli"] ]} *) let grep ?before ?after (r:Str.regexp) (sl:string list) : string list = if before = None && after = None then List.filter (StrExtra.First.matchingp r) sl else let before = Option.extract_or before 0 in let after = Option.extract_or after 0 in let sa = Array.of_list sl in let last_index = (Array.length sa) - 1 in let sl = ListExtra.mapi (fun i s -> (i,s)) sl in let xs = List.filter (fun (i,s) -> StrExtra.First.matchingp r s) sl in let parts = List.map (fun (i,line) -> let b = let before' = min before i in Array.to_list (Array.sub sa (i-before') before') in let a = Array.to_list (Array.sub sa (i+1) (min after (last_index-i))) in List.concat [b;[line];a] ) xs in List.concat parts ;; (** Here ~do_not_squeeze refers of course to the word delimiter [d]. *) let collapse_and_split ?do_not_squeeze ?(d=' ') t = let s = String.concat (Char.escaped d) t in split ?do_not_squeeze ~d s (** Merge fixed-length size groups of lines. *) let merge_lines ?(sep=" ") (n:int) xs = let xss = ArrayExtra.amass (~size:n) (Array.of_list xs) in let zs = Array.map (fun ys -> String.concat sep (Array.to_list ys)) xss in Array.to_list zs (** Converting raw text to matrix (list of list) of strings (words) and vice-versa. *) module Matrix = struct (** We call "words" the strings stored in the matrix. *) type line = word list (** A (word structured) text is a {b matrix} of strings. *) type t = word list list (** Convert a raw text in a matrix of words. By default the function [split_squeezing_blanks] is called for each line to separe words. However, specifying a delimiter [~d] and/or setting [do_not_squeeze], the conversion will call the function [split ?do_not_squeeze ?d ] instead. {b Example}: {[# Text.Matrix.of_string (UnixExtra.shell "ls -i -w1 /etc/ssh/") ;; : string list list = [["98624"; "moduli"]; ["98625"; "ssh_config"]; ["98626"; "sshd_config"]; ["274747"; "ssh_host_dsa_key"]; ["274748"; "ssh_host_dsa_key.pub"]; ["274712"; "ssh_host_key"]; ["274713"; "ssh_host_key.pub"]; ["274750"; "ssh_host_rsa_key"]; ["274751"; "ssh_host_rsa_key.pub"]] ]} *) let of_string ?do_not_squeeze ?d x = let do_not_squeeze_d, do_not_squeeze_cr = match do_not_squeeze with | None -> None, None | Some `cr -> None, (Some ()) | Some `d -> (Some ()), None | Some `neither -> (Some ()), (Some ()) in let lines = of_string ?do_not_squeeze:do_not_squeeze_cr x in if (do_not_squeeze=None) && (d=None) then List.map split_squeezing_blanks lines else List.map (split ?do_not_squeeze:do_not_squeeze_d ?d) lines (** Convert a matrix of words in a raw text. By default the word delimiter is the string [d=" "]. {[# let m = Text.Matrix.of_string (Unix.shell "ls -l /etc/ssh/") in print_string (Text.Matrix.to_string m);; total 164 -rw------- 1 root root 132839 2006-11-11 00:12 moduli -rw-r--r-- 1 root root 2517 2006-11-11 00:12 ssh_config -rw-r----- 1 root root 3474 2006-11-11 00:12 sshd_config -rw------- 1 root root 668 2006-11-20 12:50 ssh_host_dsa_key -rw-r--r-- 1 root root 600 2006-11-20 12:50 ssh_host_dsa_key.pub -rw------- 1 root root 525 2006-11-20 12:50 ssh_host_key -rw-r--r-- 1 root root 329 2006-11-20 12:50 ssh_host_key.pub -rw------- 1 root root 887 2006-11-20 12:50 ssh_host_rsa_key -rw-r--r-- 1 root root 220 2006-11-20 12:50 ssh_host_rsa_key.pub : unit = () ]}*) let to_string ?(d=" ") m = let rec line_mill acc = function | [] -> "\n"::acc | [w] -> "\n"::w::acc | w::ws -> line_mill (d::w::acc) ws in let line_list_mill = List.rev_map (line_mill []) in let ws = List.rev (List.concat (line_list_mill m)) in String.concat "" ws let from_file ?do_not_squeeze ?d s = of_string ?do_not_squeeze ?d (from_file s) end (* module Text.Matrix *) let from_file ?do_not_squeeze s = of_string ?do_not_squeeze (from_file s) end (* module Text *) (** By default the maximum line length is determined by [~width]. However, setting ?count_all this limit will be the sum of [~width] and the lengths of [?tab] and [?prefix]. *) let fmt ?tab ?prefix ?count_all ?(width=75) s = let tab_prefix = match tab with | None -> "" | Some n when n>=0 -> (String.make n ' ') | _ -> invalid_arg "StringExtra.fmt: ?tab must be positive" in let prefix = match prefix with | None -> tab_prefix | Some prefix -> tab_prefix ^ prefix in let tab_len = String.length prefix in let tab_cost = match count_all with | None -> 0 | Some () -> tab_len in let xs = List.flatten (Text.Matrix.of_string ~d:' ' s) in let rec loop acc = function | [] -> [] | (x::xs) when acc = 0 (* first word *) && tab_len=0 -> let acc' = String.length x in x::(loop acc' xs) | (x::xs) when acc = 0 (* first word *) -> let acc' = tab_cost + (String.length x) in prefix::x::(loop acc' xs) | (x::xs) as ys -> let acc' = acc + 1 + (String.length x) in if acc'>width then "\n"::(loop 0 ys) else " "::x::(loop acc' xs) in let ys = loop 0 xs in String.concat "" ys let tab ?tab ?prefix s = let tab_prefix = match tab with | None -> "" | Some n when n>=0 -> (String.make n ' ') | _ -> invalid_arg "StringExtra.tab: ?tab must be positive" in let prefix = match prefix with | None -> tab_prefix | Some prefix -> tab_prefix ^ prefix in let prefix = if prefix = "" then "\t" else prefix in let yxs = (Text.Matrix.of_string ~do_not_squeeze:`d ~d:' ' s) in let yzs = List.map (function [] -> [prefix] | x::xs -> (Printf.sprintf "%s%s" prefix x)::xs) yxs in (Text.Matrix.to_string ~d:" " yzs) let make_wide str n = if n<0 then invalid_arg "make_wide" else match String.length str with | l when l = n -> str | l when l < n -> str^(String.make (n-l) ' ') | l (* l > n*) -> String.sub str 0 n ocamlbricks-0.90+bzr456.orig/EXTRA/stackExtra.mli0000644000175000017500000000321713175721005020425 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Replacement for the standard module [Stack]. The difference with the standard [Stack] is the function [to_list] that transforms the stack in a list in O(1). *) type 'a t exception Empty val create : unit -> 'a t val clear : 'a t -> unit val copy : 'a t -> 'a t val push : 'a -> 'a t -> unit val pop : 'a t -> 'a val top : 'a t -> 'a val is_empty : 'a t -> bool val length : 'a t -> int val iter : ('a -> unit) -> 'a t -> unit val filter : ('a -> bool) -> 'a t -> unit val map : ('a -> 'a) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val rev : 'a t -> unit val rev_copy : 'a t -> 'a t (* Note that, because of the LIFO discipline, we have the equation: to_list (of_list xs) = xs *) val to_list : 'a t -> 'a list val of_list : 'a list -> 'a t (* The push against nature (the appended element will be the last out): *) val copush : 'a t -> 'a -> unit ocamlbricks-0.90+bzr456.orig/EXTRA/does-process-exist-c-wrapper.c0000644000175000017500000000415613175721005023416 0ustar lucaslucas/* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #include #include #include #include #include #include #include #include #include /* If I don't #include caml/alloc.h then this module compiles fine, but then crashes at runtime. Funny, isn't it? */ #include /* Return true iff the process identified by the given pid exists. The idea is just to call kill with 0 as a signal, which is easy in C but impossible in OCaml: */ CAMLprim value does_process_exist_c(value pid_as_an_ocaml_value){ /* Just to be pedantic: it's not a pointer, so the GC doesn't really care: */ CAMLparam1(pid_as_an_ocaml_value); /* Convert the PID from the OCaml encoding to the C encoding: */ int pid_as_c_value = Int_val(pid_as_an_ocaml_value); /* Check whether the process exists, by killing it with a 0 signal: */ const int kill_result = kill(pid_as_c_value, 0); if(kill_result == 0) CAMLreturn(Val_true); // the signal could be sent /* Ok, if we're here then the signal could *not* be sent; let's see why, by looking at errno: */ switch(errno){ case EPERM: /* The EPERM case is interesting: if we don't have the permission to kill a process, it does exist. */ CAMLreturn(Val_true); case ESRCH: CAMLreturn(Val_false); case EINVAL: // wrong signal number default: assert(false); } // switch } ocamlbricks-0.90+bzr456.orig/EXTRA/hashtblExtra.ml0000644000175000017500000000627513175721005020603 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** Make extra definitions for Hashtbl. *) type ('a, 'b) t = ('a, 'b) Hashtbl.t let search t k = try Some (Hashtbl.find t k) with Not_found -> None let to_assoc_list t = Hashtbl.fold (fun x y l -> (x,y)::l) t [] IFDEF OCAML4_OR_LATER THEN let of_assoc_list ?random ?size l = (* At least 51 buckets when size is not provided: *) let n = match size with Some n -> n | None -> max (List.length l) 51 in let ht = Hashtbl.create ?random n in let () = List.iter (fun (x,y) -> Hashtbl.add ht x y) l in ht ELSE let of_assoc_list ?random ?size l = (* At least 51 buckets when size is not provided: *) let n = match size with Some n -> n | None -> max (List.length l) 51 in let ht = Hashtbl.create (*?random*) n in let () = List.iter (fun (x,y) -> Hashtbl.add ht x y) l in ht ENDIF let remove_all t x = let ys = Hashtbl.find_all t x in List.iter (fun _ -> Hashtbl.remove t x) ys IFDEF OCAML4_OR_LATER THEN let map f t = let n = (Hashtbl.stats t).Hashtbl.num_buckets in let t' = Hashtbl.create n in let () = Hashtbl.iter (fun k v -> Hashtbl.replace t' k (f v)) t in t' let mapk f t = let n = (Hashtbl.stats t).Hashtbl.num_buckets in let t' = Hashtbl.create n in let () = Hashtbl.iter (fun k v -> Hashtbl.replace t' k (f k v)) t in t' let map2 f t1 t2 = mapk (fun k a -> let b = Hashtbl.find t2 k in f a b) t1 let map2k f t1 t2 = mapk (fun k a -> let b = Hashtbl.find t2 k in f k a b) t1 ENDIF module Make (H : Hashtbl.HashedType) = struct include Hashtbl.Make(H) let search t k = try Some (find t k) with Not_found -> None let to_assoc_list t = fold (fun x y l -> (x,y)::l) t [] let of_assoc_list ?size l = (* At least 51 buckets when size is not provided: *) let n = match size with Some n -> n | None -> max (List.length l) 51 in let ht = create (n) in let () = List.iter (fun (x,y) -> add ht x y) l in ht let remove_all t x = let ys = find_all t x in List.iter (fun _ -> remove t x) ys IFDEF OCAML4_OR_LATER THEN let map f t = let n = (stats t).Hashtbl.num_buckets in let t' = create n in let () = iter (fun k v -> replace t' k (f v)) t in t' let mapk f t = let n = (stats t).Hashtbl.num_buckets in let t' = create n in let () = iter (fun k v -> replace t' k (f k v)) t in t' let map2 f t1 t2 = mapk (fun k a -> let b = find t2 k in f a b) t1 let map2k f t1 t2 = mapk (fun k a -> let b = find t2 k in f k a b) t1 ENDIF end ocamlbricks-0.90+bzr456.orig/EXTRA/strExtra.mli0000644000175000017500000000665313175721005020137 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard library [Str]. *) (** {2 Matching result} *) type result = string * (int * int) * string list val result_as_object : result -> < matched : string; frame : int * int; groups : string list; > (** {2 Building} *) val mkregexp : ?mode:[> `inner | `prefix | `suffix | `whole ] -> ?case_insensitive:unit -> ?prefix:string list -> ?groups:string list -> ?suffix:string list -> unit -> Str.regexp (** {2 First (single) or global (multiple) matching} *) module First : sig val matching : ?frame:(int*int) -> Str.regexp -> string -> result option val matchingp : ?frame:(int*int) -> Str.regexp -> string -> bool val replace : ?frame:(int*int) -> Str.regexp -> (result -> string) -> string -> string val substitute : ?frame:(int*int) -> Str.regexp -> (string -> string) -> string -> string end module Global : sig val matching : ?frame:(int*int) -> ?overlap:unit -> Str.regexp -> string -> result list val replace : ?frame:(int*int) -> ?overlap:unit -> Str.regexp -> (result -> string) -> string -> string val substitute : ?frame:(int*int) -> ?overlap:unit -> Str.regexp -> (string -> string) -> string -> string end (** {2 Tools} *) module Posix : sig val alnum : ?exists:unit -> string -> bool val alpha : ?exists:unit -> string -> bool val ascii : ?exists:unit -> string -> bool val blank : ?exists:unit -> string -> bool val cntrl : ?exists:unit -> string -> bool val digit : ?exists:unit -> string -> bool val graph : ?exists:unit -> string -> bool val lower : ?exists:unit -> string -> bool val print : ?exists:unit -> string -> bool val punct : ?exists:unit -> string -> bool val space : ?exists:unit -> string -> bool val upper : ?exists:unit -> string -> bool val word : ?exists:unit -> string -> bool val xdigit : ?exists:unit -> string -> bool module String : sig val alnum : string val alpha : string val ascii : string val blank : string val cntrl : string val digit : string val graph : string val lower : string val print : string val punct : string val space : string val upper : string val word : string val xdigit : string end module Regexp : sig val alnum : Str.regexp val alpha : Str.regexp val ascii : Str.regexp val blank : Str.regexp val cntrl : Str.regexp val digit : Str.regexp val graph : Str.regexp val lower : Str.regexp val print : Str.regexp val punct : Str.regexp val space : Str.regexp val upper : Str.regexp val word : Str.regexp val xdigit : Str.regexp end end module Class : sig val identifierp : ?allow_dash:unit -> string -> bool end ocamlbricks-0.90+bzr456.orig/EXTRA/sysExtra.mli0000644000175000017500000000401313175721005020131 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Sys]. *) (** {2 Reading environments } *) val meaningful_getenv : string -> < non_empty_string : string option; existing_file : string option; existing_directory : string option; int : int option; float : float option; bool : bool option; > (** {2 Reading directories } *) val readdir_as_list : ?only_directories:unit -> ?only_not_directories:unit -> ?name_filter:(string -> bool) -> ?name_converter:(string -> string) -> string -> string list (** {2 Rewriting files } *) val put : ?callback:(string -> unit) -> string -> string -> unit (** {2 Signals} *) val int_of_signal : int -> int val name_of_signal : int -> string val description_of_signal : int -> string * string * string * string val description_of_name : string -> string * string * string val signal_behavior : int -> Sys.signal_behavior val iter_on_signals : ?except:(int list) -> (int -> Sys.signal_behavior -> unit) -> unit val fold_on_signals : ?except:(int list) -> ('a -> int -> Sys.signal_behavior -> 'a) -> 'a -> 'a val log_signal_reception : ?except:(int list) -> unit -> unit IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Test : sig val log_signal_reception : unit -> unit end ENDIF ocamlbricks-0.90+bzr456.orig/EXTRA/unixExtra.mli0000644000175000017500000002171513175721005020306 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard library [Unix]. *) type filename = string type dirname = string type content = string val apply_ignoring_Unix_error : ('a -> unit) -> 'a -> unit val apply_catching_Unix_error : fallback:(Unix.error * string * string -> 'b) -> ('a -> 'b) -> 'a -> 'b (** {2 File permissions} *) type symbolic_mode = (bool*bool*bool)*(bool*bool*bool)*(bool*bool*bool) val update_symbolic_mode : ?u:unit -> ?g:unit -> ?o:unit -> ?a:unit -> ?r:bool -> ?w:bool -> ?x:bool -> symbolic_mode -> symbolic_mode val get_umask : unit -> symbolic_mode val set_umask : (bool*bool*bool) -> (bool*bool*bool) -> (bool*bool*bool) -> unit val update_umask : ?u:unit -> ?g:unit -> ?o:unit -> ?a:unit -> ?r:bool -> ?w:bool -> ?x:bool -> unit -> unit val test_access : ?r:unit -> ?w:unit -> ?x:unit -> filename -> bool val touch : ?perm:Unix.file_perm -> filename -> unit val get_perm : filename -> symbolic_mode val set_perm : ?u:unit -> ?g:unit -> ?o:unit -> ?a:unit -> ?r:bool -> ?w:bool -> ?x:bool -> filename -> unit (** {2 File kinds and permissions} *) val test_kind_and_access : ?follow:unit -> (* follow symlinks *) ?f:unit -> ?d:unit -> ?c:unit -> ?b:unit -> ?l:unit -> ?p:unit -> ?s:unit -> (* kinds *) ?r:unit -> ?w:unit -> ?x:unit -> (* permissions *) filename -> bool (** {b Instances}: *) val dir_rw_or_link_to : dirname -> bool (* test_kind_and_access ~follow:() ~d:() ~r:() ~w:() *) val dir_rwx_or_link_to : dirname -> bool (* test_kind_and_access ~follow:() ~d:() ~r:() ~w:() ~x:() *) val regfile_r_or_link_to : filename -> bool (* test_kind_and_access ~follow:() ~f:() ~r:() *) val regfile_rw_or_link_to : filename -> bool (* test_kind_and_access ~follow:() ~f:() ~r:() ~w:() *) val viable_freshname : filename -> bool (** {2 Copying files} *) val file_copy : ?buffer_size:int -> ?perm:Unix.file_perm -> filename -> filename -> unit val file_append : ?buffer_size:int -> ?perm:Unix.file_perm -> filename -> filename -> unit val file_move : filename -> filename -> unit (** {2 Saving strings} *) val put : ?perm:Unix.file_perm -> filename -> content -> unit val rewrite : ?perm:Unix.file_perm -> filename -> content -> unit val append : ?perm:Unix.file_perm -> filename -> content -> unit (** {2 Loading strings} *) val cat : filename -> string (** {2 Temporary files} *) val temp_dir : ?perm:Unix.file_perm -> ?parent:string -> ?prefix:string -> ?suffix:string -> unit -> string val temp_file : ?perm:Unix.file_perm -> ?parent:string -> ?prefix:string -> ?suffix:string -> ?content:content -> unit -> string module TMPDIR : sig val default_prefix : string val open_temp : ?perm:Unix.file_perm -> ?prefix:string -> ?suffix:string -> unit -> string * Unix.file_descr val temp_file : ?perm:Unix.file_perm -> ?prefix:string -> ?suffix:string -> unit -> string end (** {2 File kind} *) val file_kind_of_char : char -> Unix.file_kind option (** {2 Directories} *) val iter_dir : (string -> 'a) -> string -> unit val find : ?follow:unit -> ?maxdepth:int -> ?kind:char -> ?basename:string -> ?only_first:unit -> string list -> string list * exn list val find_fold : ?follow:unit -> ?maxdepth:int -> ?kind:char -> ?basename:string -> ?only_first:unit -> ('a -> string * string list * exn list -> 'a) -> 'a -> string list -> 'a val find_first_and_map : ?follow:unit -> ?maxdepth:int -> ?kind:char -> ?basename:string -> (string -> string -> 'a) -> string list -> 'a option (** {2 Password} *) val read_passwd : string -> string (** {2 Process status} *) val string_of_process_status : Unix.process_status -> string (** {2 Managing external programs} *) type command = string type program = string val path_of_implicit : program -> string option (** Version working in the both cases implicit/explicit program reference as a shell interpreter. *) val is_executable : program -> bool (** Version working in the both cases implicit/explicit program reference as a shell interpreter. *) val resolve_executable : ?realpath:unit -> program -> string option val system_or_fail : ?hide_output:bool -> ?hide_errors:bool -> command -> unit val kill_safe : int -> int -> unit exception Signal_forward of int exception Waitpid val create_process_and_wait : ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> ?forward:int list -> ?register_pid:(int->unit) -> program -> string list -> int type process_result = int * string * string val create_process_and_wait_then_get_result : ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> ?forward:int list -> ?register_pid:(int->unit) -> program -> string list -> process_result val run : ?shell:command -> ?trace:bool -> ?input:string -> command -> string * Unix.process_status val shell : ?shell:command -> ?trace:bool -> ?input:string -> command -> string (** {b Asynchronous version} *) val future : ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> ?forward:int list -> ?register_pid:(int->unit) -> program -> string list -> process_result Future.t val kfuture : ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> ?forward:int list -> ?register_pid:(int->unit) -> program -> string list -> (int -> string -> string ->'a) -> 'a Future.t val script : ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> ?forward:int list -> ?register_pid:(int->unit) -> content -> string list -> process_result val script_future : ?stdin:Endpoint.Source.t -> ?stdout:Endpoint.Sink.t -> ?stderr:Endpoint.Sink.t -> ?pseudo:string -> ?forward:int list -> ?register_pid:(int->unit) -> content -> string list -> process_result Future.t type pid = int val is_process_alive : pid -> bool module Process : sig type status = | WUNCHANGED | WEXITED of int | WSIGNALED of int | WSTOPPED of int | WCONTINUED type wait_flag = | WNOHANG | WUNTRACED | WCONTINUE val waitpid : wait_flag list -> pid -> int * status val string_of_status : status -> string (** Similar to waitpid but protected from the exception [Unix.Unix_error (Unix.EINTR, _, _)]. If this exception is raised, the function recall itself in order to wait again: *) val waitpid_non_intr : ?wait_flags:wait_flag list -> pid -> (exn, int * status) Either.t (** Similar to [waitpid_non_intr] but protected also from the exception: [Unix.Unix_error (Unix.ECHILD, _, _)] which may simply mean that the process doesn't exist or it is already terminated (and wait-ed by someone else). In this case, the function returns immediately. However, if this exception is raised when the process is still alive, this means that the process cannot be wait-ed (is not a child or a descendant). In this case, an exception [Invalid_argument] is raised. *) val join_process : pid -> unit end (* Process *) module Dir : sig type t = string val iter : ?entry_kind:Unix.file_kind -> ?follow:unit -> (string -> unit) -> t -> unit val to_list : ?entry_kind:Unix.file_kind -> ?follow:unit -> t -> string list val map : ?entry_kind:Unix.file_kind -> ?follow:unit -> (string -> 'a) -> t -> 'a list val fold : ?entry_kind:Unix.file_kind -> ?follow:unit -> ('a -> string -> 'a) -> 'a -> t -> 'a val iter_with_kind : ?follow:unit -> (string -> Unix.file_kind -> unit) -> t -> unit val to_list_with_kind : ?follow:unit -> t -> (string * Unix.file_kind) list val map_with_kind : ?follow:unit -> (string -> Unix.file_kind -> 'a) -> t -> 'a list val fold_with_kind : ?follow:unit -> ('a -> string -> Unix.file_kind -> 'a) -> 'a -> t -> 'a end (* Dir *) val date : ?gmt:unit -> ?dash:string -> ?dot:string -> ?colon:string -> ?no_time:unit -> ?no_sec:unit -> ?no_date:unit -> unit -> string val resolve_symlink : ?max_hops:int -> string -> string val is_symlink : string -> bool module Thread_unsafe : sig val realpath : ?s:unit -> string -> string option end val realpath : ?s:unit -> string -> string option ocamlbricks-0.90+bzr456.orig/EXTRA/listExtra.mli0000644000175000017500000002137613175721005020301 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [List]. *) type 'a t = 'a list val filter_map : ?acc:('b list) -> ('a -> 'b option) -> 'a list -> 'b list val filteri : ?acc:'a list -> (int -> 'a -> bool) -> 'a list -> 'a list val find_map : ('a -> 'b option) -> 'a list -> 'b val map : ?acc:'b list -> ('a -> 'b) -> 'a list -> 'b list val mapi : ?acc:'a list -> (int -> 'b -> 'a) -> 'b list -> 'a list val rev_map : ?acc:'b list -> ('a -> 'b) -> 'a list -> 'b list val rev_mapi : ?acc:'b list -> (int -> 'a -> 'b) -> 'a list -> 'b list val fold_left_zipper : ('a -> 'b list * 'b * 'b list -> 'a) -> 'a -> 'b list -> 'a val perm_fold : ?disorder:unit -> ('a -> 'b list -> 'a) -> 'a -> 'b list -> 'a val perm_iter : ?disorder:unit -> ('a list -> unit) -> 'a list -> unit val perm_map : ?disorder:unit -> ('a list -> 'b) -> 'a list -> 'b list val perm : ?disorder:unit -> 'a list -> 'a list list val comb_fold : ?disorder:unit -> k:int -> ('a -> 'b list -> 'a) -> 'a -> 'b list -> 'a val comb_iter : ?disorder:unit -> k:int -> ('a list -> unit) -> 'a list -> unit val comb_map : ?disorder:unit -> k:int -> ('a list -> 'b) -> 'a list -> 'b list val comb : ?disorder:unit -> k:int -> 'b list -> 'b list list val k_perm_fold : ?disorder:unit -> k:int -> ('a -> 'b list -> 'a) -> 'a -> 'b list -> 'a val k_perm_iter : ?disorder:unit -> k:int -> ('a list -> unit) -> 'a list -> unit val k_perm_map : ?disorder:unit -> k:int -> ('a list -> 'b) -> 'a list -> 'b list val k_perm : ?disorder:unit -> k:int -> 'a list -> 'a list list (* val comb : k:int -> 'b list -> 'b list list val comb_fold : k:int -> ('a -> 'b list -> 'a) -> 'a -> 'b list -> 'a val comb_iter : k:int -> ('a list -> unit) -> 'a list -> unit val comb_map : k:int -> ('a list -> 'b) -> 'a list -> 'b list *) (** Cartesian products: *) val product2 : 'a list -> 'b list -> ('a * 'b) list val product3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list val product4 : 'a list -> 'b list -> 'c list -> 'd list -> ('a * 'b * 'c * 'd) list val product5 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> ('a * 'b * 'c * 'd * 'e) list val product6 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> ('a * 'b * 'c * 'd * 'e * 'f) list val product7 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> ('a * 'b * 'c * 'd * 'e * 'f * 'g) list val product8 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) list type 'a tuple = 'a list val product : 'a list tuple -> 'a tuple list val map_folding : ?acc:'b list -> ('s -> 'a -> 'b * 's) -> 's -> 'a list -> 'b list val mapi_folding : ?acc:'b list -> (int -> 's -> 'a -> 'b * 's) -> 's -> 'a list -> 'b list (* --- *) val map_fold : ?acc:'b list -> ('s -> 'a -> 'b) -> ('s -> 'a -> 's) -> 's -> 'a list -> 'b list * 's val mapi_fold : ?acc:'b list -> (int -> 's -> 'a -> 'b) -> (int -> 's -> 'a -> 's) -> 's -> 'a list -> 'b list * 's val init : int -> (int -> 'a) -> 'a list val flatten : ?acc:'a list -> 'a list list -> 'a list val foreach : 'a list -> ('a -> unit) -> unit val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list val combine4 : 'a list -> 'b list -> 'c list -> 'd list -> ('a * 'b * 'c * 'd) list val combine5 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> ('a * 'b * 'c * 'd * 'e) list val combine6 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> ('a * 'b * 'c * 'd * 'e * 'f) list val combine7 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> ('a * 'b * 'c * 'd * 'e * 'f * 'g) list val combine8 : 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list -> 'g list -> 'h list -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) list val split2 : ('a * 'b) list -> 'a list * 'b list val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list val split5 : ('a * 'b * 'c * 'd * 'e) list -> 'a list * 'b list * 'c list * 'd list * 'e list val split6 : ('a * 'b * 'c * 'd * 'e * 'f) list -> 'a list * 'b list * 'c list * 'd list * 'e list * 'f list val split7 : ('a * 'b * 'c * 'd * 'e * 'f * 'g) list -> 'a list * 'b list * 'c list * 'd list * 'e list * 'f list * 'g list val split8 : ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) list -> 'a list * 'b list * 'c list * 'd list * 'e list * 'f list * 'g list * 'h list val iteri : (int -> 'a -> unit) -> 'a list -> unit val shared_property : ('a->'b) -> 'a list -> bool val cut : lengths:int list -> 'a list -> 'a list list (** {2 Generalizations} *) val head : ?n:int -> 'a list -> 'a list val tail : ?i:int -> 'a list -> 'a list val search : ('a -> bool) -> 'a list -> 'a option val searchi : ('a -> bool) -> 'a list -> (int * 'a) option val findi : ('a -> bool) -> 'a list -> (int * 'a) val first_success : ('a -> 'b option) -> 'a list -> 'b option (** {2 Set operations} *) val substract : 'a list -> 'a list -> 'a list val subset : 'a list -> 'a list -> bool val eqset : 'a list -> 'a list -> bool val intersection : 'a list -> 'a list -> 'a list val uniq : 'a list -> 'a list val remove_duplicates : ?take_first:bool -> 'a list -> 'a list val amass : size:int -> 'a list -> 'a list list (** {2 Indexes} *) val int_seq : min:int -> max:int -> incr:int -> int list val float_seq : min:float -> max:float -> incr:float -> float list val range : int -> int -> int list val interval : int -> int -> int list val indexes : 'a list -> int list val asFunction : int list -> int -> int (** {b Selecting by indexes} *) val select : 'a list -> int list -> 'a list val select_from_to : 'a list -> int -> int -> 'a list (** {b Removing by indexes} *) val rmindex : 'a list -> int -> 'a list (** {b Searching for indexes} *) val indexSuchThat : ('a -> bool) -> 'a list -> int option val indexOf : 'a -> 'a list -> int option val firstIndexOf : 'a -> 'a list -> int option val lastIndexOf : 'a -> 'a list -> int option (** {2 Permutations} *) val shuffle : 'a list -> 'a list val permute : (int -> int) -> 'a list -> 'a list val shuffler : 'a list -> int -> int val shuffleIndexes : 'a list -> int list val lift_to_the_top_positions : ('a -> bool) -> 'a list -> 'a list (** {2 Folding} *) val fold_binop : ('a -> 'a -> 'a) -> 'a list -> 'a val big : ('a -> 'a -> 'a) -> 'a list -> 'a val max : 'a list -> 'a val min : 'a list -> 'a val best : ?choice:('a -> 'a -> 'a) -> 'a list -> 'a (** {2 Printing} *) val printf : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string, unit, string) format -> 'a list -> unit val eprintf : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string, unit, string) format -> 'a list -> unit val sprintf : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string, unit, string) format -> 'a list -> string val to_string : ?frame:(string -> string, unit, string) format -> ?sep:string -> ('a -> string) -> 'a list -> string (** {2 List of lists} *) val transpose : 'a list list -> 'a list list (** Association lists. Not more than 1 binding per key ensured. *) module Assoc : sig val mem : 'a -> ('a * 'b) list -> bool val remove : 'a -> ('a * 'b) list -> ('a * 'b) list val find : 'a -> ('a * 'b) list -> 'b val add : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list val set : ('a * 'b) list -> 'a -> 'b -> ('a * 'b) list (* add with flipped arguments *) val find_first : 'a list -> ('a * 'b) list -> 'b end (** Association lists (with physical equality). Not more than 1 binding per key ensured. *) module Assq : sig val mem : 'a -> ('a * 'b) list -> bool val remove : 'a -> ('a * 'b) list -> ('a * 'b) list val find : 'a -> ('a * 'b) list -> 'b val add : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list val set : ('a * 'b) list -> 'a -> 'b -> ('a * 'b) list (* add with flipped arguments *) val find_first : 'a list -> ('a * 'b) list -> 'b end ocamlbricks-0.90+bzr456.orig/EXTRA/listExtra.ml0000644000175000017500000005544713175721005020136 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo Trivial change in 2008 by Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type 'a t = 'a list (** Filter and map in the same loop using an {e heuristic} function (i.e. a function ['a -> 'b option]). *) let filter_map ?acc f = let acc = match acc with None -> [] | Some l -> l in let rec loop acc = function | [] -> acc | x::xs -> (match (f x) with | None -> (loop acc xs) | Some y -> y::(loop acc xs) ) in loop acc (** Filter according to the element and its index in the list (starting from 0). *) let filteri ?acc p = let acc = match acc with None -> [] | Some l -> l in let rec loop i = function | [] -> acc | x::xs -> if p i x then (x::(loop (i+1) xs)) else (loop (i+1) xs) in loop 0 (** Find and map in the same loop using an {e heuristic} function (i.e. a function ['a -> 'b option]). *) let rec find_map f = function | [] -> raise Not_found | x::xs -> (match (f x) with | None -> (find_map f xs) | Some y -> y ) (** As standard [List.map] but with the possibility to provide an accumulator (which will be appended to the result). *) let map ?acc f = let acc = match acc with None -> [] | Some l -> l in let rec loop acc = function | [] -> acc | x::xs -> let y = f x in (y::(loop acc xs)) in loop acc let mapi ?acc f = let acc = match acc with None -> [] | Some l -> l in let rec loop i acc = function | [] -> acc | x::xs -> let y = f i x in (y::(loop (i+1) acc xs)) in loop 0 acc (** As standard [List.rev_map] but with the possibility to provide an accumulator (which will be appended to the result). *) let rev_map ?acc f = let acc = match acc with None -> [] | Some l -> l in let rec loop acc = function | [] -> acc | x::xs -> loop ((f x)::acc) xs in loop acc let rev_mapi ?acc f = let acc = match acc with None -> [] | Some l -> l in let rec loop i acc = function | [] -> acc | x::xs -> let y = f i x in loop (i+1) (y::acc) xs in loop 0 acc (** {b Example}: {[ map_folding (fun s x -> (x+s,s+x)) 0 [0;1;2;3;4;5] ;; : int array = [|0; 1; 3; 6; 10; 15|] ]} *) let map_folding ?acc f s0 = let acc = match acc with None -> [] | Some l -> l in let rec loop s acc = function | [] -> acc | x::xs -> let (y,s') = f s x in (y::(loop s' acc xs)) in loop s0 acc let mapi_folding ?acc f s0 = let acc = match acc with None -> [] | Some l -> l in let rec loop s i acc = function | [] -> acc | x::xs -> let (y,s') = f i s x in (y::(loop s' (i+1) acc xs)) in loop s0 0 acc let map_fold ?acc fy fs s0 = let acc = match acc with None -> [] | Some l -> l in let rec loop s acc = function | [] -> (acc, s) | x::xs -> let y = fy s x in let s' = fs s x in let (res_l, res_s) = loop s' acc xs in ((y::res_l), res_s) in loop s0 acc let mapi_fold ?acc fy fs s0 = let acc = match acc with None -> [] | Some l -> l in let rec loop s i acc = function | [] -> (acc, s) | x::xs -> let y = fy i s x in let s' = fs i s x in let (res_l, res_s) = loop s' (i+1) acc xs in ((y::res_l), res_s) in loop s0 0 acc (** As standard [Array.init] but for lists. *) let init n f = if n<0 then invalid_arg "ListExtra.init" else let rec loop i = if i = n then [] else let x = f i in x::(loop (i+1)) in loop 0 (** As standard [List.flatten] but with the possibility to provide an accumulator (which will be appended to the result). *) let rec flatten ?acc = let acc = match acc with None -> [] | Some l -> l in let rec loop = function | [] -> acc | x::xs -> x @ (loop xs) in loop (** Like [List.find] but returns an option. *) let rec search p = function | [] -> None | x::xs -> if p x then (Some x) else (search p xs) let searchi p xs = let rec loop p i = function | [] -> None | x::xs -> if p x then (Some (i,x)) else (loop p (i+1) xs) in loop p 0 xs let findi p xs = match searchi p xs with | None -> raise Not_found | Some pair -> pair (* Like [List.exists] but the predicate provides also a result, which is returned. Useful to implement a choice among several fallible procedures. *) let rec first_success p = function | [] -> None | x::xs -> (match (p x) with | None -> first_success p xs | y -> y ) let iteri f = let rec loop i = function | [] -> () | x::xs -> let () = f i x in (loop (i+1) xs) in loop 0 let shared_property f = function | [] -> true | x::xs -> let y = lazy (f x) in List.for_all (fun x -> (f x)=(Lazy.force y)) xs (** Move some elements on the top of the list. {b Example}: {[# lift_to_the_top_positions ((=)"suggested") ["a";"b";"suggested";"c"] ;; : string list = ["suggested"; "a"; "b"; "c"] ]}*) let lift_to_the_top_positions pred xs = let (ys,zs) = List.partition pred xs in List.append ys zs open Sugar (** Similar to the standard [List.hd], but retrieve the list of first elements (by default [n=1] as in [List.hd]). Thus, the result is a list. *) let rec head ?(n:int=1) (l:'a list) : ('a list) = if n<=0 then [] else let n = (n-1) in match l with | [] -> [] | x::r -> x::(head ~n r) (** Similar to the standard [List.tl], but the tail is extracted from the given index (by default [i=1] as in [List.tl]) *) let rec tail ?(i:int=1) (l:'a list) = if (i=0) then l else tail ~i:(i-1) (List.tl l) (** Substract the second argument from the first *) let substract = fun u d -> let p=(fun y -> not (List.mem y d)) in (List.filter p u) (** [subset a b] check if [a] is a subset of [b], i.e. if all elements of a belong to b. *) let subset a b = List.for_all (fun x->(List.mem x b)) a (** [eqset a b] check if a and b represent the same set of values. *) let eqset a b = (subset a b) && (subset b a) (** Intersection of list: AvB=A\(A\B) . *) let intersection a b = substract a (substract a b) (** Shortcut for [List.iter] with arguments in the opposite order: before the list, then the action to perfom. *) let foreach l f = List.iter f l (** Returns a list with no duplicates. For large lists we suggest to use {!Hashset.uniq} instead. *) let rec uniq = function | [] -> [] | x::r -> if (List.mem x r) then (uniq r) else x::(uniq r) (** As [uniq] but with the optional argument [take_first] you can set the policy for taking elements. By default the policy is the opposite of [uniq], i.e. you take the first occurrence, not the last. *) let remove_duplicates ?(take_first=true) = let rec loop acc = match take_first with | true -> (function | [] -> acc | x::xs -> if (List.mem x acc) then (loop acc xs) else (loop (x::acc) xs) ) | false -> (function | [] -> acc | x::xs -> if (List.mem x xs) then (loop acc xs) else (loop (x::acc) xs) ) in function xs -> List.rev (loop [] xs) ;; (** {b Example}: {[# let xs = ['a';'b';'c';'d';'e';'f';'g';'h';'i';'j'] ;; #ListExtra.amass 3 xs ;; : char list list = [['a'; 'b'; 'c']; ['d'; 'e'; 'f']; ['g'; 'h'; 'i']; ['j']] # xs = List.concat (ListExtra.amass 3 xs) ;; : bool = true ]}*) let amass ~size xs = if size <= 0 then invalid_arg "ListExtra.amass: size must be greater than zero" else let rec loop i acc1 acc2 xs = if i>size then loop 1 [] ((List.rev acc1)::acc2) xs else match xs with | [] -> if acc1=[] then acc2 else (List.rev acc1)::acc2 | x::xs -> loop (i+1) (x::acc1) acc2 xs in List.rev (loop 1 [] [] xs) (** {b Example}: {[# int_seq 3 10 2 ;; : int list = [3; 5; 7; 9] ]}*) let int_seq ~min ~max ~incr = let rec loop x = if x>max then [] else x::(loop (x+incr)) in loop min ;; let float_seq ~min ~max ~incr = let tollerance = incr /. 2. in let max = max +. tollerance in let rec loop x = if x > max then [] else x::(loop (x+.incr)) in loop min ;; (** [range a b] returns the list [\[a; (a+1); .. ; (b-1); b\]] containing all the values between the given limits (included) . *) let range (a:int) (b:int) = let rec range a b acc = if a>b then acc else (range a (b-1) (b::acc)) in range a b [] (** Alias for range. *) let interval = range (** The list of indexes of a list. The first index is [0] as usually. *) let indexes l = range 0 ((List.length l)-1);; (** Consider a list as a function from indexes to its content. The function is the identity outside the indexes of the list. *) let asFunction l = fun i -> try (List.nth l i) with _ -> i (** Considering a list as a record and select some fields (indexes). Example: {[# select ["aaa";"bbb";"ccc"] [1;2;0;1];; : string list = ["bbb"; "ccc"; "aaa"; "bbb"] ]} *) let select (l:'a list) (fieldlist:int list) = let a = Array.of_list l in let rec loop = function | [] -> [] | f::fl -> (Array.get a f)::(loop fl) in loop fieldlist (** Example: {[# select_from_to [0;1;2;3;4;5;6] 2 5 ;; : int list = [2; 3; 4; 5] ]} *) let select_from_to xs a b = try Array.to_list (Array.sub (Array.of_list xs) a (b-a+1)) with Invalid_argument _ -> invalid_arg "ArrayExtra.select_from_to" (** Remove the element with the given index. *) let rmindex l i = let rec rmindex acc = function | (0,x::xs) -> List.append (List.rev acc) xs | (i,x::xs) -> rmindex (x::acc) (i-1,xs) | (_,[]) -> failwith "rmindex: index out of bounds" in rmindex [] (i,l) (** Search for the first index of an element satisfying a property. *) let indexSuchThat (pred:'a->bool) (l:'a list) : (int option) = let rec indexOf pred l i = (match l with | [] -> None | y::r when (pred y) -> Some i | y::r -> indexOf pred r (i+1) ) in indexOf pred l 0 (** Search for the first index of an element in a list *) let indexOf (x:'a) (l:'a list) : (int option) = indexSuchThat ((=)x) l (** Alias for [indexOf]. *) let firstIndexOf = indexOf (** Search for the last index of an element in a list *) let lastIndexOf x l = let n = List.length l in match indexOf x (List.rev l) with | None -> None | Some i -> Some (n-1-i) (** Returns a permutation of the list. *) let rec shuffle l = if l = [] then [] else let i = Random.int (List.length l) in let l' = (rmindex l i) in (List.nth l i)::(shuffle l') (** List permutation. The first argument is the function [f] that represents the permutation (we suppose that this function will be a bijection w.r.t. the set of indexes of the given list). In other words [permute f l] is the list [\[(f 0) ; (f 1) ; (f 2) ; ... \] ]. *) let permute f l = List.map (fun i -> List.nth l (f i)) (indexes l) (** Return a random permutation function for the given list. *) let shuffler l = l => (indexes || shuffle || asFunction ) (** Return a random list of indexes for the given list. *) let shuffleIndexes l = l => (indexes || shuffle) (** The {e folding} of lists is simply a [List.fold_left] specialization: - the first element is the {b head} of the list - the folding is performed on the {b tail} of the list. This function is adequate for most common cases. *) let big f = function | [] -> invalid_arg "ListExtra.big: I cannot fold an empty list" | [x] -> x | x::r -> List.fold_left f x r (* Alias for `big': *) let fold_binop f = function | [] -> invalid_arg "ListExtra.fold_binop: I cannot fold an empty list" | [x] -> x | x::r -> List.fold_left f x r (** {b Common foldings} *) (** By default the best is the minimal element, i.e. the choice function is set by default to [min]. *) let best ?(choice=min) = function | [] -> invalid_arg "ListExtra.best: empty list" | x::xs -> List.fold_left (fun s x -> choice s x) x xs (** The polymorphic maximum of a list. *) let max (l:'a list) : 'a = big max l;; (** The polymorphic minimum of a list. *) let min (l:'a list) : 'a = big min l;; (** Transpose the matrix (list of lists). Raise [Invalid_argument "transpose"] if the argument is not a matrix. {b Example}: {[# ListExtra.transpose [[1;2;3]; [4;5;6]; [7;8;9]];; : int list list = [[1; 4; 7]; [2; 5; 8]; [3; 6; 9]] ]}*) let transpose ll = let aa = ArrayExtra.Matrix.of_list ll in let aa' = ArrayExtra.Matrix.transpose aa in let ll' = ArrayExtra.Matrix.to_list aa' in ll' let rec combine3 l1 l2 l3 = match (l1,l2,l3) with | [] , [] , [] -> [] | x1::r1, x2::r2, x3::r3 -> (x1,x2,x3)::(combine3 r1 r2 r3) | _ -> raise (Invalid_argument "combine3") let rec combine4 l1 l2 l3 l4 = match (l1,l2,l3,l4) with | [] , [] , [] , [] -> [] | x1::r1, x2::r2, x3::r3, x4::r4 -> (x1,x2,x3,x4)::(combine4 r1 r2 r3 r4) | _ -> raise (Invalid_argument "combine4") let rec combine5 l1 l2 l3 l4 l5 = match (l1,l2,l3,l4,l5) with | [] , [] , [] , [] , [] -> [] | x1::r1, x2::r2, x3::r3, x4::r4, x5::r5 -> (x1,x2,x3,x4,x5)::(combine5 r1 r2 r3 r4 r5) | _ -> raise (Invalid_argument "combine5") ;; let rec combine6 l1 l2 l3 l4 l5 l6 = match (l1,l2,l3,l4,l5,l6) with | [] , [] , [] , [] , [] , [] -> [] | x1::r1, x2::r2, x3::r3, x4::r4, x5::r5, x6::r6 -> (x1,x2,x3,x4,x5,x6)::(combine6 r1 r2 r3 r4 r5 r6) | _ -> raise (Invalid_argument "combine6") ;; let rec combine7 l1 l2 l3 l4 l5 l6 l7 = match (l1,l2,l3,l4,l5,l6,l7) with | [] , [] , [] , [] , [] , [] , [] -> [] | x1::r1, x2::r2, x3::r3, x4::r4, x5::r5, x6::r6, x7::r7 -> (x1,x2,x3,x4,x5,x6,x7)::(combine7 r1 r2 r3 r4 r5 r6 r7) | _ -> raise (Invalid_argument "combine7") ;; let rec combine8 l1 l2 l3 l4 l5 l6 l7 l8 = match (l1,l2,l3,l4,l5,l6,l7,l8) with | [] , [] , [] , [] , [] , [] , [] , [] -> [] | x1::r1, x2::r2, x3::r3, x4::r4, x5::r5, x6::r6, x7::r7, x8::r8 -> (x1,x2,x3,x4,x5,x6,x7,x8)::(combine8 r1 r2 r3 r4 r5 r6 r7 r8) | _ -> raise (Invalid_argument "combine8") ;; (** {2 split 2-8} *) let split2 = List.split ;; let rec split3 l = match l with | [] -> ([],[],[]) | (x1,x2,x3)::r -> let (s1,s2,s3) = (split3 r) in (x1::s1,x2::s2,x3::s3) ;; let rec split4 l = match l with | [] -> ([],[],[],[]) | (x1,x2,x3,x4)::r -> let (s1,s2,s3,s4) = (split4 r) in (x1::s1,x2::s2,x3::s3,x4::s4) ;; let rec split5 l = match l with | [] -> ([],[],[],[],[]) | (x1,x2,x3,x4,x5)::r -> let (s1,s2,s3,s4,s5) = (split5 r) in (x1::s1,x2::s2,x3::s3,x4::s4,x5::s5) ;; let rec split6 l = match l with | [] -> ([],[],[],[],[],[]) | (x1,x2,x3,x4,x5,x6)::r -> let (s1,s2,s3,s4,s5,s6) = (split6 r) in (x1::s1,x2::s2,x3::s3,x4::s4,x5::s5,x6::s6) ;; let rec split7 l = match l with | [] -> ([],[],[],[],[],[],[]) | (x1,x2,x3,x4,x5,x6,x7)::r -> let (s1,s2,s3,s4,s5,s6,s7) = (split7 r) in (x1::s1,x2::s2,x3::s3,x4::s4,x5::s5,x6::s6,x7::s7) ;; let rec split8 l = match l with | [] -> ([],[],[],[],[],[],[],[]) | (x1,x2,x3,x4,x5,x6,x7,x8)::r -> let (s1,s2,s3,s4,s5,s6,s7,s8) = (split8 r) in (x1::s1,x2::s2,x3::s3,x4::s4,x5::s5,x6::s6,x7::s7,x8::s8) ;; (** Cartesian products: *) let rec product2 xs ys = match xs with | [] -> [] | x::xs -> List.append (List.map (fun y -> (x,y)) ys) (product2 xs ys) ;; let rec product3 xs ys zs = match xs with x::xs -> List.append (List.map (fun (y,z) -> (x,y,z)) (product2 ys zs)) (product3 xs ys zs) | [] -> [] ;; let rec product4 xs ys zs us = match xs with x::xs -> List.append (List.map (fun (y,z,u) -> (x,y,z,u)) (product3 ys zs us)) (product4 xs ys zs us) | [] -> [] ;; let rec product5 xs ys zs us vs = match xs with x::xs -> List.append (List.map (fun (y,z,u,v) -> (x,y,z,u,v)) (product4 ys zs us vs)) (product5 xs ys zs us vs) | [] -> [] ;; let rec product6 xs ys zs us vs ts = match xs with x::xs -> List.append (List.map (fun (y,z,u,v,t) -> (x,y,z,u,v,t)) (product5 ys zs us vs ts)) (product6 xs ys zs us vs ts) | [] -> [] ;; let rec product7 xs ys zs us vs ts ws = match xs with x::xs -> List.append (List.map (fun (y,z,u,v,t,w) -> (x,y,z,u,v,t,w)) (product6 ys zs us vs ts ws)) (product7 xs ys zs us vs ts ws) | [] -> [] ;; let rec product8 xs ys zs us vs ts ws ls = match xs with x::xs -> List.append (List.map (fun (y,z,u,v,t,w,l) -> (x,y,z,u,v,t,w,l)) (product7 ys zs us vs ts ws ls)) (product8 xs ys zs us vs ts ws ls) | [] -> [] ;; (* General case: *) type 'a tuple = 'a list (** {b Example}: # product [[1;2;3];[4;5];[6]] ;; : int list list = [[1; 4; 6]; [1; 5; 6]; [2; 4; 6]; [2; 5; 6]; [3; 4; 6]; [3; 5; 6]] *) let rec product : 'a list tuple -> 'a tuple list = function | [] -> [] | [xs] -> List.map (fun x -> [x]) xs | xs::yss -> match xs with | x::xs -> List.append (List.map (fun ys -> x::ys) (product yss)) (product (xs::yss)) | [] -> [] ;; module Assoc = struct let mem = List.mem_assoc let remove = List.remove_assoc let find = List.assoc let add x y xys = (x,y)::(List.remove_assoc x xys) let set xys x y = add x y xys let rec find_first xs ys = match xs with | [] -> raise Not_found | x::xs -> try List.assoc x ys with Not_found -> find_first xs ys end module Assq = struct let mem = List.mem_assq let remove = List.remove_assq let find = List.assq let add x y xys = (x,y)::(List.remove_assq x xys) let set xys x y = add x y xys let rec find_first xs ys = match xs with | [] -> raise Not_found | x::xs -> try List.assq x ys with Not_found -> find_first xs ys end (** {b Example}: {[ # cut ~lengths:[1;2;3;0;2] [0;1;2;3;4;5;6;7;8;9] ;; : int list list = [[0]; [1; 2]; [3; 4; 5]; []; [6; 7]] ]} *) let cut ~lengths xs = let start_len_list_of_lengths xs = let js,_ = List.fold_left (fun (js,n) x -> ((n+x)::js,n+x)) ([0],0) xs in List.combine (List.rev (List.tl js)) xs in let a = Array.of_list xs in let start_len_list = start_len_list_of_lengths lengths in try let segments = List.map (fun (start, len) -> Array.sub a start len) start_len_list in List.map Array.to_list segments with Invalid_argument s -> invalid_arg (Printf.sprintf "ListExtra.cut (%s)" s) (** Similar to [List.fold_left] but the iterated function takes three values [(xs, x, xs')], instead of just [x], as second argument. In any loop, the value [xs] are the elements already treated in a {b reversed} order (because it's a zipper, we look at the traversed structure from the [x] point of view). Conversely, [xs'] are the elements that will be treated in the next loops, and this list is not reversed. See [ListExtra.perm_fold] for an example of application. *) let fold_left_zipper f y0 = let rec loop acc y = function | [] -> y | x::xs -> let y' = f y (acc,x,xs) in loop (x::acc) y' xs in loop [] y0 (** Fold traversing the permutations of the given list. {b Example}: {[# perm_fold (fun () [x;y;z] -> Printf.printf "(%d,%d,%d)\n" x y z) () [1;2;3] ;; (1,2,3) (1,3,2) (2,1,3) (2,3,1) (3,1,2) (3,2,1) : unit = () ]} *) let rec perm_fold ?disorder f y = let append = match disorder with | None -> List.rev_append | Some () -> (@) in function | [] -> y | x::[] as xs -> f y xs | xs -> fold_left_zipper (fun y (xs,x,xs') -> let f' a bl = f a (x::bl) in perm_fold f' y (append xs xs')) y xs (** Iterate on all permutations of the given list. {b Example}: {[# perm_iter (function [x;y;z] -> Printf.printf "(%d,%d,%d)\n" x y z | _ -> assert false) [1;2;3] ;; (1,2,3) (1,3,2) (2,1,3) (2,3,1) (3,1,2) (3,2,1) : unit = () ]} *) let perm_iter ?disorder f xs = perm_fold ?disorder (fun () xs -> f xs) () xs let perm ?disorder xs = match disorder with | None -> List.rev (perm_fold (fun y c -> c::y) [] xs) | Some () -> perm_fold ~disorder:() (fun y c -> c::y) [] xs let perm_map ?disorder f xs = match disorder with | None -> List.rev (perm_fold (fun y c -> (f c)::y) [] xs) | Some () -> perm_fold ~disorder:() (fun y c -> (f c)::y) [] xs (** Fold traversing the combinations of the given list. *) let comb_fold ?disorder= match disorder with | None -> fun ~k f y0 xs -> let rec loop acc k y xs = if k=1 then List.fold_left (fun y x -> f y (List.rev_append acc [x])) y xs else fold_left_zipper (fun y (_,x,xs') -> loop (x::acc) (k-1) y xs') y xs in loop [] k y0 xs | Some () -> fun ~k f y0 xs -> (* Here to preserve the equation: comb ~k xs = List.sort compare (comb ~disorder:() ~k xs) supposing xs sorted *) let xs = List.rev xs in let rec loop acc k y xs = if k=1 then List.fold_left (fun y x -> f y (x::acc)) y xs else fold_left_zipper (fun y (_,x,xs') -> loop (x::acc) (k-1) y xs') y xs in loop [] k y0 xs (** Iterate on all combinations of [k] elements of the given list. *) let comb_iter ?disorder ~k f = comb_fold ?disorder ~k (fun () c -> f c) () (** Map a function on all combinations of [k] elements of the given list. *) let comb_map ?disorder ~k f = match disorder with | None -> fun xs -> List.rev (comb_fold ~k (fun y c -> (f c)::y) [] xs) | Some () -> comb_fold ~disorder:() ~k (fun y c -> (f c)::y) [] (** Provide the list of all combinations of [k] elements of the given list. {b Example}: {[# comb ~k:2 ['a';'b';'c';'d'] ;; : char list list = [['a'; 'b']; ['a'; 'c']; ['a'; 'd']; ['b'; 'c']; ['b'; 'd']; ['c'; 'd']] ]} *) let comb ?disorder ~k = match disorder with | None -> fun xs -> List.rev (comb_fold ~k (fun y c -> c::y) [] xs) | Some () -> comb_fold ~disorder:() ~k (fun y c -> c::y) [] (** The order here is composite: first a k-combination is choosed (in their order), then its permutations are generated (in their order). *) let k_perm_fold ?disorder ~k f = comb_fold ?disorder ~k (fun y c -> perm_fold ?disorder f y c) let k_perm_iter ?disorder ~k f = k_perm_fold ?disorder ~k (fun () c -> f c) () let k_perm ?disorder ~k = match disorder with | Some () -> k_perm_fold ~disorder:() ~k (fun y c -> c::y) [] | None -> fun xs -> List.rev (k_perm_fold ~k (fun y c -> c::y) [] xs) let k_perm_map ?disorder ~k f = match disorder with | None -> fun xs -> List.rev (k_perm_fold ~k (fun y c -> (f c)::y) [] xs) | Some () -> k_perm_fold ~disorder:() ~k (fun y c -> (f c)::y) [] (* --- Printing --- *) (** {b Examples}: {[# sprintf "%.2f" [1.;2.;3.;4.] ;; : string = "[1.00; 2.00; 3.00; 4.00]" # sprintf ~frame:"The list is (%s)" ~sep:", " "%.2f" [1.;2.;3.;4.] ;; : string = "The list is (1.00, 2.00, 3.00, 4.00)" ]} *) let sprintf ?frame ?(sep="; ") fmt xs = let content = String.concat sep (List.map (Printf.sprintf fmt) xs) in match frame with | None -> Printf.sprintf "[%s]" content | Some fmt -> Printf.sprintf fmt content let printf ?frame ?sep fmt xs = Printf.printf "%s" (sprintf ?frame ?sep fmt xs) let eprintf ?frame ?sep fmt xs = Printf.eprintf "%s" (sprintf ?frame ?sep fmt xs) let to_string ?frame ?sep f xs = let ys = List.map f xs in sprintf ?frame ?sep "%s" ys ocamlbricks-0.90+bzr456.orig/EXTRA/filenameExtra.mli0000644000175000017500000000261013175721005021074 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Filename]. *) val add_extension_if_absent : string -> string -> string val get_extension : ?with_dot:unit -> string -> string option val get_extension_or_default : ?with_dot:unit -> ?default:string -> string -> string val concat_list : string list -> string val temp_dir : ?temp_dir:string -> ?prefix:string -> ?suffix:string -> ?perm:int -> unit -> string val to_absolute : ?parent:string -> string -> string val make_explicit : string -> string val remove_trailing_slashes_and_dots : ?make_explicit:unit -> string -> string val append_trailing_unique_slash : ?make_explicit:unit -> string -> string ocamlbricks-0.90+bzr456.orig/EXTRA/ooExtra.ml0000644000175000017500000000425613175721005017570 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Support for managing the component garbage. *) class virtual destroy_methods () = let mrproper = new Thunk.lifo_unit_protected_container () in object (* Accessor to the inner mrproper object: *) method mrproper = mrproper (* Automatically protected and considered as one-shot (linear) thunk: *) method add_destroy_callback f = ignore (mrproper#register_lazy f) (* Initially private, but may became public: *) method private destroy = mrproper#apply () end (* destroy_methods *) module Gc_sync = struct let finalizer (f : int -> unit) ~oid ~finalizer_hook = let g = fun _ -> f oid in Gc.finalise g finalizer_hook let notify = (Printf.kfprintf flush stderr "Gc_sync: instance %d collected.\n") class ['a] t ?destroy (v:'a) = object (self) val content = ref v (* in the heap *) method get = !content (** For each set a full major collection is called. In this way the unlinked value may be immediately collected (if unused elsewhere) raising its finalization. *) method set x = content := x; Gc.full_major (); (* The container itself have a finalizer: *) initializer let destroy = match destroy with | None -> notify | Some f -> f in finalizer destroy ~oid:(Oo.id self) ~finalizer_hook:content end let ref = new t;; (** {b Example}: {[let x = ref ([ref 2; ref 1; ref 0]) ;; x#set [] ;; Gc_sync: instance 6 collected!!! Gc_sync: instance 5 collected!!! Gc_sync: instance 4 collected!!! : unit = () ]} *) endocamlbricks-0.90+bzr456.orig/EXTRA/threadExtra.mli0000644000175000017500000000616713175721005020576 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2011 2012 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Similar to [Thread.create] with two differences: (1) you may create a killable thread (but only a limited number of threads of your application may be killable at the same time) (2) you are able to call [ThreadExtra.at_exit] in the function ('a -> 'b) that will be executed in the created thread. *) val create : ?killable:unit -> ('a -> 'b) -> 'a -> Thread.t (** Create a thread that waits for a process termination. By default the process is killed if the application terminates (by default we suppose that the application is the father and the owner of this process). *) val waitpid_thread : ?killable:unit -> ?before_waiting:(pid:int -> unit) -> ?after_waiting:(pid:int -> Unix.process_status -> unit) -> ?perform_when_suspended:(pid:int -> unit) -> ?perform_when_resumed:(pid:int -> unit) -> ?fallback:(pid:int -> exn -> unit) -> ?do_not_kill_process_if_exit:unit -> unit -> (pid:int -> Thread.t) (** Apply [Unix.fork] immediately creating a thread that waits for the termination of this fork. *) val fork_with_tutor : ?killable:unit -> ?before_waiting:(pid:int->unit) -> ?after_waiting:(pid:int -> Unix.process_status -> unit) -> ?perform_when_suspended:(pid:int -> unit) -> ?perform_when_resumed:(pid:int -> unit) -> ?fallback:(pid:int -> exn -> unit) -> ?do_not_kill_process_if_exit:unit -> ('a -> 'b) -> 'a -> Thread.t module Easy_API : sig type options val make_options : ?enrich:options -> ?killable:unit -> ?before_waiting:(pid:int->unit) -> ?after_waiting:(pid:int -> Unix.process_status -> unit) -> ?perform_when_suspended:(pid:int -> unit) -> ?perform_when_resumed:(pid:int -> unit) -> ?fallback:(pid:int -> exn -> unit) -> ?do_not_kill_process_if_exit:unit -> unit -> options val waitpid_thread : ?options:options -> unit -> (pid:int -> Thread.t) val fork_with_tutor : ?options:options -> ('a -> 'b) -> 'a -> Thread.t end (* Easy_API *) val at_exit : (unit -> unit) -> unit val kill : Thread.t -> bool val killall : unit -> unit val killable : unit -> int list val killer : Thread.t -> unit -> unit val set_killable_with_thunk : ?who:Thread.t -> (unit -> unit) -> unit val id_kill : int -> bool val id_killer : int -> unit -> unit val delayed_kill : float -> Thread.t -> unit val delayed_killall : float -> unit val delayed_id_kill : float -> int -> unit val delay : float -> unit ocamlbricks-0.90+bzr456.orig/EXTRA/strExtra.ml0000644000175000017500000003736213175721005017767 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007-2011 Jean-Vincent Loddo Trivial changes: Copyright (C) 2007 Luca Saiu Other minor changes in 2008 by Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** {b Meaning:} this type represents the result of a matching between a regular expression and a string {b when it succeeds}. A result [(x,(a,b),gl)] means that: - there exists a substring [x] of the input string that matches the regular expression; - the integers [a] and [b] (the {e frame}) are the positions (indexes) of the beginning and the end of the substring [x] w.r.t. the input string; - the value [gl] is the list of substrings which have matched the groups defined in the regular expression; the length of this list will be equal to the number of groups defined in the regular expression. {b Examples}: {[ # let r = mkregexp ~prefix:["("] ~groups:["[0-9]*"; "[,]?"; "[0-9]*"] ~suffix:[")"] () ;; val r : Str.regexp = # First.matching r "abcd" ;; : StrExtra.result option = None # First.matching r "(16,7)" ;; : StrExtra.result option = Some ("(16,7)", (0, 5), ["16"; ","; "7"]) # let x = object_of_result (Option.extract (First.matching r "(16,7)")) ;; val x : < frame : int * int; groups : string list; matched : string > = # x#frame ;; : int * int = (0, 5) # x#matched ;; : string = "(16,7)" # x#groups ;; : string list = ["16"; ","; "7"] ]}*) type result = string * (int * int) * string list (** An more explicit structured version of a matching result: *) let result_as_object (matched,frame,groups) = object method matched = matched method frame = frame method groups = groups end (** Facility for building regular expressions. The call [mkregexp ~prefix ~groups ~suffix ()] causes the following actions: - the strings in [prefix] are simply catenated in a unique string (the {e prefix}) - the strings in [groups] are catenated enclosing each one into ["\\("] and ["\\)"] in order to define distinct {e groups} - the strings in [suffix] are simply catenated in a unique string (the {e suffix}) - the result is the compiled regexp of the catenation of {e prefix}, {e groups} and {e suffix} {b in this order}. The optional parameter [mode] has type [[> `prefix, `suffix, `whole, `inner]] and sets the meaning of the regular expression as pattern: a prefix-pattern, a suffix-pattern, a whole-pattern or an {b inner-pattern} (which is the default). In other words, the string obtained as described above, is modified prepending ["^"] if [mode] is in [[`prefix; `whole]], and is modified appending ["$"] if [mode] is in [[`suffix; `whole]]. So, by default nothing is prepended or appended. *) let mkregexp ?(mode=`inner) ?case_insensitive ?(prefix=[]) ?(groups=[]) ?(suffix=[]) () = let concat = String.concat "" in let prefix_pattern = concat prefix in let groups_pattern = concat (List.map (fun x-> concat ["\\("; x ;"\\)"]) groups) in let suffix_pattern = concat suffix in let left_pattern = match mode with `prefix | `whole -> "^" | _ -> "" in let right_pattern = match mode with `suffix | `whole -> "$" | _ -> "" in let expr = concat [left_pattern; prefix_pattern; groups_pattern ; suffix_pattern; right_pattern] in match case_insensitive with | None -> Str.regexp expr | Some () -> Str.regexp_case_fold expr (** The call [matched_groups i x] returns the list of substrings of [x] matching groups starting from the group number [i]. See the standard [Str.matched_group] for more details. *) let rec matched_groups i x : (string list) = try let g=(Str.matched_group i x) in g::(matched_groups (i+1) x) with _ -> [] (** The heuristic [match_frame r s (a,b)] try to match the substring [(a,b)] of the string [s] with the compiled regular expression [r]. *) let match_frame (r:Str.regexp) (s:string) (a,b) : result option = try let s = String.sub s a (b-a+1) in let i = Str.search_forward r s 0 in let y = Str.matched_string s in let j = (Str.match_end ())-1 in Some (y, (a+i,a+j), (matched_groups 1 s)) with Not_found -> None (** The heuristic [match_whole r s (a,b)] try to match the whole string [s] with the compiled regular expression [r]. *) let match_whole (r:Str.regexp) (s:string) : result option = try let a = Str.search_forward r s 0 in let y = Str.matched_string s in let b = (Str.match_end ())-1 in Some (y, (a,b), (matched_groups 1 s)) with Not_found -> None (** Looking for a first (and single) matching or substitution. *) module First = struct (** Try to match the whole string or a frame of it (if specified) with the regular expression. {b Example}: {[# First.matching (Str.regexp "[0-9]+") "---12---345---6---7890---" ;; : StrExtra.result option = Some ("12", (3, 4), []) ]} *) let matching ?frame regexp s = match frame with | None -> match_whole regexp s | Some ab -> match_frame regexp s ab (** Predicative version of [matching]. The answer is simply a boolean value indicating if they matches. {b Example}: {[# First.matchingp (Str.regexp "[0-9]+") "---12---345---6---7890---" ;; : bool = true ]} *) let matchingp ?frame regexp s = ((matching ?frame regexp s) <> None) (** Similar to the standard [Str.substitute_first] but the value used to substitute is built from a function taking the [result] of the matching (not the whole string as for [Str.substitute_first]). {b Example}: {[# First.replace (Str.regexp "[0-9]+") (fun (x,(a,b),gs) -> if a<10 then x^x else x^x^x) "---12---345---6---7890---" ;; : string = "---1212---345---6---7890---" ]} *) let replace ?frame regexp f s = let s = match frame with | None -> s | Some (a,b) -> String.sub s a (b-a+1) in match (match_whole regexp s) with | None -> s | Some r -> let y = f r in Str.replace_first regexp y s (** Similar to the standard [Str.substitute_first] but the value used to substitute is built from a function taking the matched substring (not the whole string as for [Str.substitute_first]. {b Example}: {[# First.substitute (Str.regexp "[0-9]+") (fun x -> x^x) "---12---345---6---7890---" ;; : string = "---1212---345---6---7890---" ]} *) let substitute ?frame regexp f s = let s = match frame with | None -> s | Some (a,b) -> String.sub s a (b-a+1) in match (match_whole regexp s) with | None -> s | Some (x,_,_) -> let y = f x in Str.replace_first regexp y s end (* module First *) (** Multiple matchings or substitutions. *) module Global = struct (** Get all matches of the regexp with portions of the given string. {b Example}: {[# Global.matching (Str.regexp "[0-9]+") "---12---345---6---7890---" ;; : result list = [("12", (3, 4), []); ("345", (8, 10), []); ("6", (14, 14), []); ("7890", (18, 21), [])] ]} The optional parameter [overlap] allows the user to match substrings that overlapped each other. This behaviour concerns only regular expressions {b with groups}: when a matching occurs, the next will be searched immediately after the first matched group, not after the whole matched substring. {b Example}: {[# Global.matching (Str.regexp "[0-9]+ [0-9]+") "111 222 333 aaa 444" ;; : result list = [("111 222", (0, 6), [])] # Global.matching ~overlap:() (mkregexp ~groups:["[0-9]+"; " "; "[0-9]+"] ()) "111 222 333 aaa 444" ;; : result list = [("111 222", (0, 6), ["111"; " "; "222"]); ("222 333", (4, 10), ["222"; " "; "333"])] ]}*) let matching ?frame ?overlap regexp s = let s = match frame with | None -> s | Some (a,b) -> String.sub s a (b-a+1) in let n = String.length s in let next = match overlap with | None -> fun (a,b) -> b+1 | Some () -> fun (a,b) -> try (Str.group_end 1)+1 with _ -> b+1 in let rec loop i = if i >=n then [] else try let a = Str.search_forward regexp s i in let y = Str.matched_string s in let b = (Str.match_end ())-1 in let answer = (y, (a,b), (matched_groups 1 s)) in answer::(loop (next (a,b))) with Not_found -> [] in loop 0 (** Replace all matches of the regexp with a value calculated from the matching result. {b Example}: {[# Global.replace (Str.regexp "[0-9]+") (fun (x,(a,b),gs) -> if a<10 then x else x^x) "---12---345---6---7890---" ;; : string = "---12---345---66---78907890---" ]} *) let replace ?frame ?overlap regexp f s = let s = match frame with | None -> s | Some (a,b) -> String.sub s a (b-a+1) in let results = matching ?overlap regexp s in let (i,xs) = List.fold_left (fun (i,xs) ((_,(a,b),_) as result) -> let y = f result in let i'= b+1 in let xs' = y::(String.sub s i (max 0 (a-i)))::xs in (i', xs')) (0,[]) results in let n = String.length s in let xs = (String.sub s i (n-i))::xs in (String.concat "" (List.rev xs)) (** Replace all matches of the regexp with a value calculated from the {b matched string} of the matching result. {b Example}: {[# Global.substitute (Str.regexp "[0-9]+") (fun x -> x^x) "---12---345---6---7890---" ;; : string = "---1212---345345---66---78907890---" ]} *) let substitute ?frame ?overlap regexp f = replace ?frame ?overlap regexp (fun (x,_,_) -> f x) end (* module Global *) (** Posix character classes. By default the meaning of predicates is {b for all} character in the string the character belongs to the corresponding Posix class. The dual interpretation {b it exists} (a character in the string such that) may be forced with the optional parameter. *) module Posix = struct (** Alphanumeric characters [[a-zA-Z0-9]] *) let alnum ?exists = First.matchingp (Str.regexp (if exists=None then "^[a-zA-Z0-9]*$" else "[a-zA-Z0-9]")) (** Alphabetic characters [[a-zA-Z]] *) let alpha ?exists = First.matchingp (Str.regexp (if exists=None then "^[a-zA-Z]*$" else "[a-zA-Z]")) (** ASCII characters [[\x00-\x7F]] *) let ascii ?exists = First.matchingp (Str.regexp (if exists=None then "^[\x00-\x7F]*$" else "[\x00-\x7F]")) (** Space and tab [[ \t]] *) let blank ?exists = First.matchingp (Str.regexp (if exists=None then "^[ \t]*$" else "[ \t]")) (** Control characters [[\x00-\x1F\x7F]] *) let cntrl ?exists = First.matchingp (Str.regexp (if exists=None then "^[\x00-\x1F\x7F]*$" else "[\x00-\x1F\x7F]")) (** Digits [[0-9]] *) let digit ?exists = First.matchingp (Str.regexp (if exists=None then "^[0-9]*$" else "[0-9]")) (** Visible characters (i.e. anything except spaces, control characters, etc.) [[\x21-\x7E]] *) let graph ?exists = First.matchingp (Str.regexp (if exists=None then "^[\x21-\x7E]*$" else "[\x21-\x7E]")) (** Lowercase letters [[a-z]] *) let lower ?exists = First.matchingp (Str.regexp (if exists=None then "^[a-z]*$" else "[a-z]")) (** Visible characters and spaces (i.e. anything except control characters, etc.) [[\x20-\x7E]] *) let print ?exists = First.matchingp (Str.regexp (if exists=None then "^[\x20-\x7E]*$" else "[\x20-\x7E]")) (** Punctuation and symbols *) let punct ?exists = First.matchingp (Str.regexp (if exists=None then "^[!\"#$%&'()*+,\\-./:;<=>?@[\\]^_`{|}~]*$" else "[!\"#$%&'()*+,\\-./:;<=>?@[\\]^_`{|}~]")) (** All whitespace characters, including line breaks [[ \t\r\n\\v\\f]] *) let space ?exists = First.matchingp (Str.regexp (if exists=None then "^[ \t\r\n\\v\\f]*$" else "[ \t\r\n\\v\\f]")) (** Uppercase letters [[A-Z]] *) let upper ?exists = First.matchingp (Str.regexp (if exists=None then "^[A-Z]*$" else "[A-Z]")) (** Word characters (letters, numbers and underscores) [[A-Za-z0-9_]] *) let word ?exists = First.matchingp (Str.regexp (if exists=None then "^[A-Za-z0-9_]*$" else "[A-Za-z0-9_]")) (** Hexadecimal digits [[A-Fa-f0-9]] *) let xdigit ?exists = First.matchingp (Str.regexp (if exists=None then "^[A-Fa-f0-9]*$" else "[A-Fa-f0-9]")) (** Posix character classes as regular expressions *) module Regexp = struct (** Alphanumeric characters [[a-zA-Z0-9]] *) let alnum = Str.regexp "[a-zA-Z0-9]" (** Alphabetic characters [[a-zA-Z]] *) let alpha = Str.regexp "[a-zA-Z]" (** ASCII characters [[\x00-\x7F]] *) let ascii = Str.regexp "[\x00-\x7F]" (** Space and tab [[ \t]] *) let blank = Str.regexp "[ \t]" (** Control characters [[\x00-\x1F\x7F]] *) let cntrl = Str.regexp "[\x00-\x1F\x7F]" (** Digits [[0-9]] *) let digit = Str.regexp "[0-9]" (** Visible characters (i.e. anything except spaces, control characters, etc.) [[\x21-\x7E]] *) let graph = Str.regexp "[\x21-\x7E]" (** Lowercase letters [[a-z]] *) let lower = Str.regexp "[a-z]" (** Visible characters and spaces (i.e. anything except control characters, etc.) [[\x20-\x7E]] *) let print = Str.regexp "[\x20-\x7E]" (** Punctuation and symbols *) let punct = Str.regexp "[!\"#$%&'()*+,\\-./:;<=>?@[\\]^_`{|}~]" (** All whitespace characters, including line breaks [[ \t\r\n\\v\\f]] *) let space = Str.regexp "[ \t\r\n\\v\\f]" (** Uppercase letters [[A-Z]] *) let upper = Str.regexp "[A-Z]" (** Word characters (letters, numbers and underscores) [[A-Za-z0-9_]] *) let word = Str.regexp "[A-Za-z0-9_]" (** Hexadecimal digits [[A-Fa-f0-9]] *) let xdigit = Str.regexp "[A-Fa-f0-9]" end (* module Posix.Regexp *) (** Posix classes as strings. Useful for making regular expressions, for instance with [StrExtra.mkregexp]. *) module String = struct (** Alphanumeric characters [[a-zA-Z0-9]] *) let alnum = "[a-zA-Z0-9]" (** Alphabetic characters [[a-zA-Z]] *) let alpha = "[a-zA-Z]" (** ASCII characters [[\x00-\x7F]] *) let ascii = "[\x00-\x7F]" (** Space and tab [[ \t]] *) let blank = "[ \t]" (** Control characters [[\x00-\x1F\x7F]] *) let cntrl = "[\x00-\x1F\x7F]" (** Digits [[0-9]] *) let digit = "[0-9]" (** Visible characters (i.e. anything except spaces, control characters, etc.) [[\x21-\x7E]] *) let graph = "[\x21-\x7E]" (** Lowercase letters [[a-z]] *) let lower = "[a-z]" (** Visible characters and spaces (i.e. anything except control characters, etc.) [[\x20-\x7E]] *) let print = "[\x20-\x7E]" (** Punctuation and symbols *) let punct = "[!\"#$%&'()*+,\\-./:;<=>?@[\\]^_`{|}~]" (** All whitespace characters, including line breaks [[ \t\r\n\\v\\f]] *) let space = "[ \t\r\n\\v\\f]" (** Uppercase letters [[A-Z]] *) let upper = "[A-Z]" (** Word characters (letters, numbers and underscores) [[A-Za-z0-9_]] *) let word = "[A-Za-z0-9_]" (** Hexadecimal digits [[A-Fa-f0-9]] *) let xdigit = "[A-Fa-f0-9]" end end (** Some common classes (identifiers,...) *) module Class = struct (** Check if a string can be used as an identifier, i.e. if it matches [[^[a-zA-Z][a-zA-Z0-9_]*$]] (without dashes) or [[^[a-zA-Z][a-zA-Z0-9_\\-]*$]] (with dashes). *) let identifierp = let with_dash = Str.regexp "^[a-zA-Z][a-zA-Z0-9_\\-]*$" in let without_dash = Str.regexp "^[a-zA-Z][a-zA-Z0-9_]*$" in fun ?allow_dash -> match allow_dash with | None -> First.matchingp without_dash | Some () -> First.matchingp with_dash endocamlbricks-0.90+bzr456.orig/EXTRA/arrayExtra.ml0000644000175000017500000006005513175721005020270 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type 'a t = 'a array (** Equivalent to the standard [Array.of_list] but the list is not scanned twice. The function raises [Invalid_argument] if the real length of the list differs from the announced. *) let of_known_length_list ?(reversing=false) len = function | [] -> [||] | x::xs -> let a = Array.make len x in if reversing then (let rec fill i = function | [] -> (if i=(-1) then a else invalid_arg "unexpected list length (overstated size)") | x::xs -> (try a.(i) <- x with _ -> invalid_arg "unexpected list length (understated size)"); fill (i-1) xs in fill (len-2) xs) else (let rec fill i = function | [] -> (if i=len then a else invalid_arg "unexpected list length (overstated size)") | x::xs -> (try a.(i) <- x with _ -> invalid_arg "unexpected list length (understated size)"); fill (i+1) xs in fill 1 xs) (** {b Example}: {[ # init2 3 (fun i -> (i+1,i*2)) ;; : int array * int array = ([|1; 2; 3|], [|0; 2; 4|]) ]} *) let init2 n f = if n = 0 then ([||],[||]) else let (x0,y0) = f 0 in let xs = Array.make n x0 in let ys = Array.make n y0 in for i = 1 to (n-1) do let (x,y) = f i in xs.(i) <- x; ys.(i) <- y; done; (xs,ys) let split xys = init2 (Array.length xys) (fun i -> xys.(i)) let combine xs ys = Array.init (Array.length xs) (fun i -> xs.(i), ys.(i)) let sorted_copy ?(compare=Pervasives.compare) xs = let ys = (Array.copy xs) in (Array.sort compare ys); ys let fast_sorted_copy ?(compare=Pervasives.compare) xs = let ys = (Array.copy xs) in (Array.fast_sort compare ys); ys (** Sort the array saving the position of each element in the original array. {b Example}: {[ ArrayExtra.sort_saving_positions [| 6.28; 3.14; 1.41; 2.71 |] ;; : (int * float) array = [|(2, 1.41); (3, 2.71); (1, 3.14); (0, 6.28)|] ]} *) let sort_saving_positions ?(compare=Pervasives.compare) (xs:'a array) : (int * 'a) array = let ys = Array.mapi (fun i x -> (x,i)) xs in let () = Array.sort (fun (x,_) (y,_) -> compare x y) ys in Array.map (fun (p,i) -> (i,p)) ys let sort_saving_permutation ?(compare=Pervasives.compare) (xs:'a array) : (int array) * ('a array) = let ys = Array.mapi (fun i x -> (x,i)) xs in let () = Array.sort (fun (x,_) (y,_) -> compare x y) ys in let xs, js = split ys in (js, xs) (** {b Example}: {[ let xs = [| 23; 21; 10; 5; 9; 0; 2; 12; |] ;; let js, ys = ArrayExtra.sort_saving_permutation xs ;; val js : int array = [|5; 6; 3; 4; 2; 7; 1; 0|] val ys : int array = [|0; 2; 5; 9; 10; 12; 21; 23|] ys = (ArrayExtra.apply_permutation js xs) ;; : bool = true xs = (ArrayExtra.undo_permutation js ys) ;; : bool = true ]} *) let apply_permutation js xs = let ys = Array.copy xs in let () = Array.iteri (fun i j -> ys.(i) <- xs.(j)) js in ys let undo_permutation js xs = let ys = Array.copy xs in let () = Array.iteri (fun i j -> ys.(j) <- xs.(i)) js in ys let is_sorted ?(compare=Pervasives.compare) s : bool = let l = Array.length s in if l = 0 then true else (* continue: *) let rec loop pred i = if i>=l then true else let x = s.(i) in if (compare pred x) = 1 then false else loop x (i+1) in loop s.(0) 1 let sort_in_the_same_way ?compare xs yss = let perm, xs' = sort_saving_permutation ?compare xs in let yss' = List.map (apply_permutation perm) yss in perm, xs', yss' (** {b Example}: {[# int_seq 3 10 2 ;; : int array = [|3; 5; 7; 9|] ]}*) let int_seq ~min ~max ~incr = let rec loop x = if x>max then [] else x::(loop (x+incr)) in let xs = loop min in Array.of_list xs let float_seq ~min ~max ~incr = let tollerance = incr /. 2. in let max = max +. tollerance in let rec loop x = if x>max then [] else x::(loop (x+.incr)) in let xs = loop min in Array.of_list xs (** Similar to the standard [List.for_all], implemented directly, i.e. without conversion. *) let for_all p s = let l = Array.length s in let rec loop i = if i>=l then true else (p i s.(i)) && loop (i+1) in loop 0 (** Similar to the standard [List.exists], implemented directly, i.e. without conversion. *) let exists p s = let l = Array.length s in let rec loop i = if i>=l then false else (p i s.(i)) || loop (i+1) in loop 0 (** As the function [exists], but provides the index that verifies the predicate. *) let lexists p s = let l = Array.length s in let rec loop i = if i>=l then None else if (p i s.(i)) then (Some i) else loop (i+1) in loop 0 (** As the function [lexists], but searching from the right side. *) let rexists p s = let l = Array.length s in let rec loop i = if i<0 then None else if (p i s.(i)) then (Some i) else loop (i-1) in loop (l-1) let search p s = let l = Array.length s in let rec loop i = if i>=l then None else let x = s.(i) in if (p x) then (Some x) else loop (i+1) in loop 0 let searchi p s = let l = Array.length s in let rec loop i = if i>=l then None else let x = s.(i) in if (p x) then (Some (i,x)) else loop (i+1) in loop 0 let find p s = let l = Array.length s in let rec loop i = if i>=l then raise Not_found else let x = s.(i) in if (p x) then x else loop (i+1) in loop 0 let findi p s = let l = Array.length s in let rec loop i = if i>=l then raise Not_found else let x = s.(i) in if (p x) then (i,x) else loop (i+1) in loop 0 let shared_property f s = let l = Array.length s in if l=0 then true else let y = lazy (f s.(0)) in let p = (fun x -> (f x)=(Lazy.force y)) in let rec loop i = if i>=l then true else (p s.(i)) && loop (i+1) in loop 1 module Dichotomic = struct (** Supposing the array sorted, this function find the index of the leftmost supremum (least upper bound) of the provided value. In other words, it computes j = min {i | x <= v.(i) }. The result is None if there are no upper bounds for {x} in the array. A result as Some (true,j) means that v.(j) = x, while Some (false,j) means x < v.(j). {b Example}: {[ dichotomic_leftmost_ge 3 [| 0;2;4;4;4;4;4;6;8;10 |];; : (bool * index) option = Some (false, 2) dichotomic_leftmost_ge 4 [| 0;2;4;4;4;4;4;6;8;10 |];; : (bool * index) option = Some (true, 2) dichotomic_leftmost_ge 5 [| 0;2;4;4;4;4;4;6;8;10 |];; : bool * index) option = Some (false, 7) dichotomic_leftmost_ge 100 [| 0;2;4;4;4;4;4;6;8;10 |];; : (bool * index) option = None ]} *) let dichotomic_leftmost_ge ?(compare=Pervasives.compare) ?(a=0) ?b x v = (* precedentemente dichotomic_search *) let eq x y = (compare x y) = 0 in let lt x y = (compare x y) = (-1) in let le x y = let r = (compare x y) in r = (-1) || r = 0 in let b = match b with None -> (Array.length v)-1 | Some b -> b in let (a0, b0) = (a, b) in let rec loop a b = if a=b then a else (* a < b *) let i = (a+b)/2 in (* note that (i+1) <= b by construction *) if (lt v.(i) x) then loop (i+1) b else (* At this point, x <= v.(i), i.e. we have found an upper bound *) if (i > a0) && (le x v.(i-1)) then loop a (i-1) else (* v.(i-1) < x <= v.(i) or (i=a0 and x<=v.(a0)) *) i in if lt x v.(a) then Some (false,a) else (* continue: *) if lt v.(b) x then None (* there are no upper bounds *) else (* continue: *) let i = loop a b in Some ((eq v.(i) x),i) (** Supposing the array sorted, this function find the index of the rightmost infimum (greatest lower bound) of the provided value. In other words, it computes: j = max {i | v.(i) <= x }. The result is None if there are no lower bounds for {x} in the array. A result as Some (true,j) means that v.(j) = x, while Some (false,j) means v.(j) < x. {b Example}: {[ dichotomic_rightmost_le (-100) [| 0;2;4;4;4;4;4;6;8;10 |];; : (bool * index) option = None dichotomic_rightmost_le 3 [| 0;2;4;4;4;4;4;6;8;10 |];; : (bool * index) option = Some (false, 1) dichotomic_rightmost_le 5 [| 0;2;4;4;4;4;4;6;8;10 |];; : (bool * index) option = Some (false, 6) ]} *) let dichotomic_rightmost_le ?(compare=Pervasives.compare) ?(a=0) ?b x v = let eq x y = (compare x y) = 0 in let lt x y = (compare x y) = (-1) in let le x y = let r = (compare x y) in r = (-1) || r = 0 in let b = match b with None -> (Array.length v)-1 | Some b -> b in let (a0, b0) = (a, b) in let rec loop a b = if a=b then a else (* a < b *) let i = (a+b+1)/2 in (* note that (i-1) >= a by construction *) if (lt x v.(i)) then loop a (i-1) else (* At this point, v.(i) <= x, i.e. we have found a lower bound *) if (i < b0) && (le v.(i+1) x) then loop (i+1) b else (* v.(i) <= x < v.(i+1) or (i=b0 and v.(b0)<=x) *) i in if lt x v.(a) then None (* there are no lower bounds *) else (* continue: *) if lt v.(b) x then Some (false,b) else (* continue: *) let i = loop a b in Some ((eq v.(i) x),i) let dichotomic_frame ?compare ?a ?b x v = let inf = dichotomic_rightmost_le ?compare ?a ?b x v in (* v.(inf) <= x *) if inf = None then None else (* continue: *) let sup = dichotomic_leftmost_ge ?compare ?a ?b x v in (* x <= v.(sup) *) if sup = None then None else (* continue: *) match (inf, sup) with | (Some (false, i)), (Some (false, j)) -> Some (i,j) | (Some (true, i)), (Some (true, j)) -> Some (j,i) (* because v.(i)=v.(j) and the inf (i) is the rightmost while the sup (j) is the leftmost *) | _,_ -> assert false (* Redefinition with ?unicity *) (** {b Example}: {[ # let xs = [| 0; 10; 20; 30; 40; 40; 40; 40; 80; 90; 100; |] (* There are duplicates! *) ;; # let ys = [| 0; 10; 20; 30; 40; 50; 60; 70; 80; 90; 100; |] (* Unicity! *) ;; # dichotomic_frame 30 xs ;; : (int * int) option = Some (3, 3) # dichotomic_frame 40 xs ;; : (int * int) option = Some (4, 7) # dichotomic_frame ~unicity:() 40 ys ;; (* suppose (and exploit) unicity! *) : (int * int) option = Some (4, 4) # dichotomic_frame 42 xs ;; : (int * int) option = Some (7, 8) # dichotomic_frame 101 xs ;; : (int * int) option = None # dichotomic_frame (-1) ;; : (int * int) option = None ]} *) let dichotomic_frame ?compare ?a ?b ?unicity x v = match unicity with | None -> dichotomic_frame ?compare ?a ?b x v | Some () -> let a = match a with None -> 0 | Some a -> a in let sup = dichotomic_leftmost_ge ?compare ~a ?b x v in (* x <= v.(sup) *) (match sup with | None -> None (* In the following two cases we suppose the unicity (no duplicated values in the array) *) | Some (false,i) -> if i = a then None else Some (i-1,i) | Some (true,i) -> Some (i,i) ) let dichotomic_leftmost_gt ?(compare=Pervasives.compare) ?(a=0) ?b ?unicity x v = if compare v.(a) x = 1 then Some a else match dichotomic_frame ~compare ~a ?b ?unicity x v with | None -> None | Some (i,j) -> if (compare v.(i) v.(j) = 0) then let b = match b with None -> (Array.length v)-1 | Some b -> b in let j' = j+1 in if j' > b then None else Some j' else Some j let dichotomic_rightmost_lt ?(compare=Pervasives.compare) ?a ?b ?unicity x v = let b = match b with None -> (Array.length v)-1 | Some b -> b in if compare x v.(b) = 1 then Some b else match dichotomic_frame ~compare ?a ~b ?unicity x v with | None -> None | Some (i,j) -> if (compare v.(i) v.(j) = 0) then let a = match a with None -> 0 | Some a -> a in let i' = i-1 in if i' < a then None else Some i' else Some i end (* Dichotomic *) (* Included at toplevel: *) include Dichotomic let for_all2 f xs ys = for_all (fun i x -> f i x ys.(i)) xs let exists2 f xs ys = exists (fun i x -> f i x ys.(i)) xs let iter2 f a b = Array.iteri (fun i a -> f a b.(i)) a let iteri2 f a b = Array.iteri (fun i a -> f i a b.(i)) a let map2 f a b = Array.mapi (fun i a -> f a b.(i)) a let mapi2 f a b = Array.mapi (fun i a -> f i a b.(i)) a (** {b Example}: {[ map_folding (fun s i x -> (x+s,s+x)) 0 [|0;1;2;3;4;5|] ;; : int array = [|0; 1; 3; 6; 10; 15|] ]} *) let mapi_folding (f : int -> 's -> 'a -> 'b * 's) (s0 : 's) (xs : 'a array) : 'b array = let n = Array.length xs in if n = 0 then [||] else begin let (y0, s1) = f 0 s0 (xs.(0)) in let result = Array.make n y0 in let state = ref s1 in for i = 1 to n-1 do let (y,z) = f i (!state) (xs.(i)) in result.(i) <- y ; state := z; done; result end let map_folding (f : 's -> 'a -> 'b * 's) (s0 :'s) (xs : 'a array) : 'b array = let n = Array.length xs in if n = 0 then [||] else begin let (y0, s1) = f s0 (xs.(0)) in let result = Array.make n y0 in let state = ref s1 in for i = 1 to n-1 do let (y,z) = f (!state) (xs.(i)) in result.(i) <- y ; state := z; done; result end (* --- *) (* val mapi_fold : (int -> 's -> 'a -> 'b) -> (int -> 's -> 'a -> 's) -> 's -> 'a array -> 'b array * 's *) let mapi_fold fy fs s0 xs = let n = Array.length xs in if n = 0 then ([||], s0) else begin let y0 = fy 0 s0 (xs.(0)) in let s1 = fs 0 s0 (xs.(0)) in let result = Array.make n y0 in let state = ref s1 in for i = 1 to n-1 do let s = !state in let x = xs.(i) in result.(i) <- fy i s x; state := fs i s x; done; (result, !state) end (* val map_fold : ('s -> 'a -> 'b) -> ('s -> 'a -> 's) -> 's -> 'a array -> 'b array * 's *) let map_fold fy fs s0 xs = let n = Array.length xs in if n = 0 then ([||], s0) else begin let y0 = fy s0 (xs.(0)) in let s1 = fs s0 (xs.(0)) in let result = Array.make n y0 in let state = ref s1 in for i = 1 to n-1 do let s = !state in let x = xs.(i) in result.(i) <- fy s x; state := fs s x; done; (result, !state) end let fold_lefti f y0 s = let l = Array.length s in let rec loop acc i = if i>=l then acc else let acc = f i acc s.(i) in loop acc (i+1) in loop y0 0 let fold_righti f s y0 = let l = Array.length s in let rec loop acc i = if i<0 then acc else let acc = f i s.(i) acc in loop acc (i-1) in loop y0 (l-1) let fold_left2 f s0 xs ys = fold_lefti (fun i s x -> f s x ys.(i)) s0 xs let fold_right2 f xs ys s0 = fold_righti (fun i x s -> f x ys.(i) s) xs s0 let fold_lefti2 f s0 xs ys = fold_lefti (fun i s x -> f i s x ys.(i)) s0 xs let fold_righti2 f xs ys s0 = fold_righti (fun i x s -> f i x ys.(i) s) xs s0 let fold_binop f s = let l = Array.length s in if l = 0 then invalid_arg "ArrayExtra.fold_binop: I cannot fold an empty array" else let rec loop acc i = if i>=l then acc else let acc = f acc s.(i) in loop acc (i+1) in loop s.(0) 1 (** Similar to [List.partition] but for arrays and with many classes. {b Example}: {[ # partition (fun x -> x mod 3) [|0;1;2;3;4;5;6;7;8;9|] ;; : int array array = [|[|0; 3; 6; 9|]; [|1; 4; 7|]; [|2; 5; 8|]|] ]} *) let partition = let errmsg = "ArrayExtra.partition: classifier must provide only non-negative integers" in fun ?(min_size=0) f a -> (* f' is a dynamically type checking version of f: *) let f' x = (let y = f x in (if (y<0) then invalid_arg errmsg); y) in let max_index = Array.fold_left (fun s x -> max s (f' x)) (-1) a in if max_index = -1 then Array.make min_size [||] else let ls = Array.make (max min_size (max_index+1)) [] in (Array.iter (fun x -> let c = f x in ls.(c) <- x :: ls.(c)) a); let result = Array.map (fun l -> Array.of_list (List.rev l)) ls in result let partitioni = let errmsg = "ArrayExtra.partitioni: classifier must provide only non-negative integers" in fun ?(min_size=0) f a -> (* f' is a dynamically type checking version of f: *) let f' i x = (let y = f i x in (if (y<0) then invalid_arg errmsg); y) in let max_index = fold_lefti (fun i s x -> max s (f' i x)) (-1) a in if max_index = -1 then Array.make min_size [||] else let ls = Array.make (max min_size (max_index+1)) [] in (Array.iteri (fun i x -> let c = f i x in ls.(c) <- x :: ls.(c)) a); let result = Array.map (fun l -> Array.of_list (List.rev l)) ls in result (** {b Example}: {[ # amass ~size:3 [|1;2;3;4;5;6;7;8;9;10|] ;; : int array array = [|[|1; 2; 3|]; [|4; 5; 6|]; [|7; 8; 9|]; [|10|]|] ]} *) let amass ?group_no ?size xs = let size = match size, group_no with | (Some s), _ -> s | None, (Some g) -> let n = Array.length xs in let k = n/g in if n mod g > 0 then k+1 else k (* I want exactly g groups *) | None, None -> invalid_arg "ArrayExtra.amass: at leat one of the parameters ~size or ~group_no must be provided" in if size <= 0 then invalid_arg "ArrayExtra.amass: size must be greater than zero" else partitioni (fun i x -> i/size) xs (** {b Example}: {[ # flatten [|[|1; 2; 3|]; [|4; 5; 6|]; [|7; 8; 9|]; [|10|]|] ;; : int array = [|1; 2; 3; 4; 5; 6; 7; 8; 9; 10|] ]} *) let flatten xss = Array.concat (Array.to_list xss) (** {b Example}: {[ # cut [1;2;3;0;2] [|0;1;2;3;4;5;6;7;8;9|];; : int array list = [[|0|]; [|1; 2|]; [|3; 4; 5|]; [||]; [|6; 7|]] ]} *) let cut ~lengths xs = let start_len_list_of_lengths xs = let js,_ = List.fold_left (fun (js,n) x -> ((n+x)::js,n+x)) ([0],0) xs in List.combine (List.rev (List.tl js)) xs in let start_len_list = start_len_list_of_lengths lengths in try List.map (fun (start, len) -> Array.sub xs start len) start_len_list with Invalid_argument s -> invalid_arg (Printf.sprintf "ArrayExtra.cut (%s)" s) (** As standard [Array.sub] but with optional length (if not provided, the length is defined in order to take the rest of the list after the given position) *) let sub ?len xs pos = let len = match len with | None -> (Array.length xs) - pos | Some n -> n in Array.sub xs pos len (** Tools for matrices (arrays of arrays). *) module Matrix = struct type 'a t = 'a array array (** [init m n f] returns a fresh [m] x [n] matrix with element [(i,j)] initialized to the result of [(f i j)]. *) let init m n f = Array.init m (fun i -> Array.init n (f i)) (** Make a matrix from a list of lists. *) let of_list ll = if ll = [] then [||] else let rows = List.length ll in Array.init rows (fun row -> Array.of_list (List.nth ll row)) (** Make a list of lists from a matrix. *) let to_list aa = let al = Array.map Array.to_list aa in Array.to_list al (** Transpose the matrix. *) let transpose aa = let m = Array.length aa in let n = Array.length aa.(0) in if (for_all (fun i a -> (Array.length a) = n) aa) then init n m (fun i j -> aa.(j).(i)) else invalid_arg "transpose: the argument is not a matrix." end (** By default the best is the minimal element, i.e. the choice function is set by default to [min]. *) let best ?(choice=min) = function | [||] -> invalid_arg "ArrayExtra.best: empty array" | xs -> fold_lefti (fun i (j,x) y -> if (choice x y) <> x then (i,y) else (j,x)) (0, xs.(0)) xs let max ?(gt=(>)) xs = fold_lefti (fun i (j,x) y -> if gt y x then (i,y) else (j,x)) (0, xs.(0)) xs let min ?(gt=(>)) xs = fold_lefti (fun i (j,x) y -> if gt y x then (j,x) else (i,y)) (0, xs.(0)) xs (** Example (from the module [Ipv6]): {[let search_longest_sequence_of_zeros ?leftmost = ArrayExtra.search_longest_sequence ?leftmost ((=)0);; ]}*) let search_longest_sequence ?leftmost p x = let (last,_, acc) = fold_lefti (fun i ((n,j), inseq, acc) v -> if p v then (* if we are in a sequence, increment the counter: *) (if inseq then ((n+1,j), true, acc) (* else reset the counter registering the current result in the list: *) else ((1,i), true, ((n,j)::acc))) else (* register that the sequence is finished inseq=false: *) ((n,j), false, acc)) ((0,0), false, []) x in let njs = last::acc in let (best_n, best_j) = let candidates = match leftmost with | None -> njs | Some () -> List.rev njs in List.fold_left (fun ((best_n, best_j) as a) ((n,j) as b) -> if n>best_n then b else a) (List.hd candidates) (List.tl candidates) in if best_n > 0 then Some (best_j, best_n) else None ;; let random_permutation xs = let n = Array.length xs in let js = Array.init n (fun i -> i) in let () = Array.iteri (fun i x -> let choice = i + (Random.int (n-i)) in js.(i)<-js.(choice); js.(choice)<-x) js in Array.map (fun j -> xs.(j)) js let frequence pred xs = let n = Array.length xs in if n=0 then invalid_arg "ArrayExtra.frequence: empty array" else (* continue: *) let occ = Array.fold_left (fun occ x -> if (pred x) then occ+1 else occ) 0 xs in let freq = (float_of_int occ) /. (float_of_int n) in (occ, freq) let count pred xs = let n = Array.length xs in if n=0 then invalid_arg "ArrayExtra.count: empty array" else (* continue: *) Array.fold_left (fun occ x -> if (pred x) then occ+1 else occ) 0 xs let values_such_that (p : int -> 'a -> bool) xs = let ys = fold_lefti (fun i ys x -> if p i x then x::ys else ys) [] xs in List.rev ys let indexes_such_that (p : int -> 'a -> bool) xs = let ys = fold_lefti (fun i ys x -> if p i x then i::ys else ys) [] xs in List.rev ys let indexes_and_values_such_that (p : int -> 'a -> bool) xs = let ys = fold_lefti (fun i ys x -> if p i x then (i,x)::ys else ys) [] xs in List.rev ys (** {[# let gs, gvs = group_by (fun x -> (x mod 3), (x, x*x)) [| 0;1;2;3;4;5;6;7;8;9 |] ;; val gs : int array = [|0; 1; 2|] val gvs : (int, (int * int) array) M.t = # Hashtbl.find gvs 0 ;; : int array = [|(0, 0); (3, 9); (6, 36); (9, 81)|] # Hashtbl.find gvs 1 ;; : int array = [|(1, 1); (4, 16); (7, 49)|] # Hashtbl.find gvs 2 ;; : (int * int) array = [|(2, 4); (5, 25); (8, 64)|] ]} *) let group_by f xs = let n = Array.length xs in let ht = Hashtbl.create n in (* domain with the first position where we have found this element in the array *) let domain = Hashtbl.create n in let domain_add b i = if Hashtbl.mem domain b then () else Hashtbl.replace domain b i in (* --- *) let () = Array.iteri (fun i a -> let (b,c) = f a in (Hashtbl.add ht b c; domain_add b i)) xs in let domain = Array.of_list (Hashtbl.fold (fun x i ixs -> (i,x)::ixs) domain []) in let () = Array.sort compare domain in let domain = Array.map snd domain in (* --- *) let result = Hashtbl.create n in (* For all items in the domain, we get the list of associated value in ht: *) let () = Array.iter (fun b -> Hashtbl.replace result b (Array.of_list (List.rev (Hashtbl.find_all ht b)))) domain in domain, result (* --- Printing --- *) (** {b Examples}: {[# sprintf "%.2f" [|1.;2.;3.;4.|] ;; : string = "[|1.00; 2.00; 3.00; 4.00|]" # sprintf ~frame:"The vector is (%s)" ~sep:", " "%.2f" [|1.;2.;3.;4.|] ;; : string = "The vector is (1.00, 2.00, 3.00, 4.00)" ]} *) let sprintf ?frame ?(sep="; ") fmt xs = let content = String.concat sep (List.map (Printf.sprintf fmt) (Array.to_list xs)) in match frame with | None -> Printf.sprintf "[|%s|]" content | Some fmt -> Printf.sprintf fmt content let printf ?frame ?sep fmt xs = Printf.printf "%s" (sprintf ?frame ?sep fmt xs) let eprintf ?frame ?sep fmt xs = Printf.eprintf "%s" (sprintf ?frame ?sep fmt xs) let to_string ?frame ?sep f xs = let ys = Array.map f xs in sprintf ?frame ?sep "%s" ys ocamlbricks-0.90+bzr456.orig/EXTRA/mapExtra.mli0000644000175000017500000000674413175721005020105 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for (and instances of) the standard module [Map]. *) module type S = sig include Map.S (* Extra functions: *) val search : key -> 'a t -> 'a option val filter : (key -> 'a -> bool) -> 'a t -> 'a t val filter_map : (key -> 'a -> bool) -> ('a -> 'b) -> 'a t -> 'b t val filter_mapi : (key -> 'a -> bool) -> (key -> 'a -> 'b) -> 'a t -> 'b t val product : 'a t -> 'b t -> ('a * 'b) t val of_list : ?acc:'a t -> (key * 'a) list -> 'a t val to_list : ?acc:(key * 'a) list -> ?reverse:bool -> 'a t -> (key * 'a) list val domain : ?reverse:bool -> 'a t -> key list val codomain : ?reverse:bool -> 'a t -> 'a list val restrict : 'a t -> key list -> 'a t val substract : 'a t -> key list -> 'a t end module Extend : functor (Map : Map.S) -> S with type key = Map.key module Make : functor (Ord : Map.OrderedType) -> S with type key = Ord.t (** {2 Pre-built mappings} *) module String_map : S with type key = string module Int_map : S with type key = int (** {2 Not persistent (imperative) versions} *) module Destructive : sig (* TODO: add wrappers for the functions introduced in OCaml 3.12: *) module type S = sig type key type 'a t val create : unit -> 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> unit val find : key -> 'a t -> 'a val remove : key -> 'a t -> unit val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'a) -> 'a t -> unit val mapi : (key -> 'a -> 'a) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (* Extra functions: *) val search : key -> 'a t -> 'a option val copy : 'a t -> 'a t val filter : (key -> 'a -> bool) -> 'a t -> unit val filter_map : (key -> 'a -> bool) -> ('a -> 'a) -> 'a t -> unit val filter_mapi : (key -> 'a -> bool) -> (key -> 'a -> 'a) -> 'a t -> unit val of_list : ?acc:'a t -> (key * 'a) list -> 'a t val to_list : ?acc:(key * 'a) list -> ?reverse:bool -> 'a t -> (key * 'a) list val domain : ?reverse:bool -> 'a t -> key list val codomain : ?reverse:bool -> 'a t -> 'a list val restrict : 'a t -> key list -> unit val substract : 'a t -> key list -> unit end module Make : functor (Ord : Map.OrderedType) -> S with type key = Ord.t (* Destructive versions: *) module String_map : S with type key = string module Int_map : S with type key = int end (* Destructive *) ocamlbricks-0.90+bzr456.orig/EXTRA/hashtblExtra.mli0000644000175000017500000000471013175721005020744 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [Hashtbl]. *) type ('a, 'b) t = ('a, 'b) Hashtbl.t val remove_all : ('a, 'b) t -> 'a -> unit val search : ('a, 'b) t -> 'a -> 'b option val to_assoc_list : ('a, 'b) t -> ('a * 'b) list val of_assoc_list : ?random:bool -> ?size:int -> ('a * 'b) list -> ('a,'b) t IFDEF OCAML4_OR_LATER THEN val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t val mapk : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t val map2 : ('b -> 'c -> 'd) -> ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t val map2k : ('a -> 'b -> 'c -> 'd) -> ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t ENDIF module Make : functor (H : Hashtbl.HashedType) -> sig type key = H.t type 'a t = 'a Hashtbl.Make(H).t val create : int -> 'a t val clear : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int (* extra: *) val remove_all : 'a t -> key -> unit val search : 'a t -> key -> 'a option val to_assoc_list : 'a t -> (key * 'a) list val of_assoc_list : ?size:int -> (key * 'a) list -> 'a t (* --- *) IFDEF OCAML4_OR_LATER THEN val map : ('a -> 'b) -> 'a t -> 'b t val mapk : (key -> 'a -> 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val map2k : (key -> 'a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t ENDIF end ocamlbricks-0.90+bzr456.orig/EXTRA/stackExtra.ml0000644000175000017500000000312213175721005020247 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type 'a t = { mutable l : 'a list } exception Empty let create () = { l = [] } let clear s = s.l <- [] let copy s = { l = s.l } let push x s = s.l <- x :: s.l let pop s = match s.l with x::xs -> s.l <- xs; x | [] -> raise Empty let top s = match s.l with x::_ -> x | [] -> raise Empty let is_empty s = (s.l = []) let length s = List.length s.l let iter f s = List.iter f s.l let filter f s = (s.l <- List.filter f s.l) let map f s = (s.l <- List.map f s.l) let fold f x s = List.fold_left f x (s.l) let rev s = (s.l <- List.rev s.l) let rev_copy s = { l = List.rev s.l } (** O(1) list conversion. *) let to_list s = s.l let of_list xs = { l = xs } (* The push against nature (the appended element will be the last out): *) let copush s x = (s.l <- List.append s.l [x]) ocamlbricks-0.90+bzr456.orig/EXTRA/queueExtra.ml0000644000175000017500000000414713175721005020276 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) let to_list q = Queue.fold (fun xs x -> x::xs) [] q let of_list xs = let result = Queue.create () in let () = List.iter (fun x -> Queue.push x result) xs in result let filter_copy p q0 = let q1 = Queue.create () in let () = Queue.iter (fun x -> if p x then Queue.push x q1) q0 in q1 let filter p q0 = let q1 = Queue.create () in let () = Queue.iter (fun x -> if p x then Queue.push x q1) q0 in let () = Queue.clear q0 in Queue.iter (fun x -> Queue.push x q0) q1 let map f q0 = let q1 = Queue.create () in let () = Queue.iter (fun x -> Queue.push (f x) q1) q0 in let () = Queue.clear q0 in Queue.iter (fun x -> Queue.push x q0) q1 let map_copy f q0 = let q1 = Queue.create () in let () = Queue.iter (fun x -> Queue.push (f x) q1) q0 in q1 let rev_copy q0 = let s1 = Stack.create () in let q1 = Queue.create () in let () = Queue.iter (fun x -> Stack.push x s1) q0 in let () = Stack.iter (fun x -> Queue.push x q1) s1 in q1 let rev q0 = let s1 = Stack.create () in let () = Queue.iter (fun x -> Stack.push x s1) q0 in let () = Queue.clear q0 in Stack.iter (fun x -> Queue.push x q0) s1 (* The push against nature (the inserted element will be the first out): *) let copush q0 x = let q1 = Queue.create () in let () = Queue.push x q1 in let () = Queue.iter (fun x -> Queue.push x q1) q0 in let () = Queue.clear q0 in Queue.iter (fun x -> Queue.push x q0) q1 ocamlbricks-0.90+bzr456.orig/EXTRA/mapExtra.ml0000644000175000017500000001316413175721005017726 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../EXTRA/mapExtra.mli" ;; module Extend = functor (M:Map.S) -> struct include M (** Extra functions: *) let search (k : key) (m : 'a t) : 'a option = try Some (find k m) with Not_found -> None let filter (p : key -> 'a -> bool) (m : 'a t) : 'a t = fold (fun k a m' -> if p k a then add k a m' else m') m empty let filter_map (p : key -> 'a -> bool) (f:'a -> 'b) (m : 'a t) : 'b t = fold (fun k a m' -> if p k a then add k (f a) m' else m') m empty let filter_mapi (p : key -> 'a -> bool) (f:key -> 'a -> 'b) (m : 'a t) : 'b t = fold (fun k a m' -> if p k a then add k (f k a) m' else m') m empty let product (m1:'a t) (m2:'b t) : ('a * 'b) t = filter_mapi (fun k _ -> mem k m2) (fun k a -> (a, (find k m2))) m1 let of_list ?(acc=empty) (xs : (key * 'a) list) : 'a t = List.fold_left (fun m (k,a) -> add k a m) acc xs let to_list ?(acc=[]) ?(reverse=false) (m : 'a t) = let acc = if reverse then (List.rev acc) else acc in let l = fold (fun k a xs -> (k,a)::xs) m acc in if reverse then List.rev l else l let domain ?(reverse=true) (m : 'a t) = fst (List.split (to_list ~reverse m)) let codomain ?(reverse=true) (m : 'a t) = snd (List.split (to_list ~reverse m)) let restrict m ks = List.fold_left (fun m' k -> try add k (find k m) m' with Not_found -> m') empty ks let substract m ks = List.fold_left (fun m' k -> remove k m') m ks end module Make (Ord : Map.OrderedType) = Extend (Map.Make (Ord)) module String_map = Make (struct type t = string let compare = Pervasives.compare end) module Int_map = Make (struct type t = int let compare = Pervasives.compare end) (** The data structure is not really re-implemented: an imperative (destructive) map is simply implemented as a reference to a persistent map. This reference is update by some functions ([add], [remove], [map],...). *) module Destructive = struct module type S = sig type key type 'a t val create : unit -> 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> unit val find : key -> 'a t -> 'a val remove : key -> 'a t -> unit val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'a) -> 'a t -> unit val mapi : (key -> 'a -> 'a) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (* Extra functions: *) val search : key -> 'a t -> 'a option val copy : 'a t -> 'a t val filter : (key -> 'a -> bool) -> 'a t -> unit val filter_map : (key -> 'a -> bool) -> ('a -> 'a) -> 'a t -> unit val filter_mapi : (key -> 'a -> bool) -> (key -> 'a -> 'a) -> 'a t -> unit val of_list : ?acc:'a t -> (key * 'a) list -> 'a t val to_list : ?acc:(key * 'a) list -> ?reverse:bool -> 'a t -> (key * 'a) list val domain : ?reverse:bool -> 'a t -> key list val codomain : ?reverse:bool -> 'a t -> 'a list val restrict : 'a t -> key list -> unit val substract : 'a t -> key list -> unit end module Make (Ord : Map.OrderedType) = struct module Persistent = Make (Ord) type key = Ord.t type 'a t = 'a Persistent.t ref let create () = ref Persistent.empty let is_empty t = Persistent.is_empty (!t) let add k a t = (t := Persistent.add k a !t) let find k t = Persistent.find k (!t) let remove k t = (t := Persistent.remove k !t) let mem k t = Persistent.mem k (!t) let iter f t = Persistent.iter f (!t) let map f t = (t := Persistent.map f !t) let mapi f t = (t := Persistent.mapi f !t) let fold f t = Persistent.fold f (!t) let compare f t0 t1 = Persistent.compare f (!t0) (!t1) let equal f t0 t1 = Persistent.equal f (!t0) (!t1) (* Extra functions: *) let search k t = Persistent.search k (!t) let copy t = ref (!t) let filter f t = (t := Persistent.filter f !t) let filter_map p f t = (t := Persistent.filter_map p f !t) let filter_mapi p f t = (t := Persistent.filter_mapi p f !t) let of_list ?acc l = let acc = match acc with None -> None | Some t -> Some (!t) in ref (Persistent.of_list ?acc l) let to_list ?acc ?reverse t = Persistent.to_list ?acc ?reverse (!t) let domain ?reverse t = Persistent.domain ?reverse (!t) let codomain ?reverse t = Persistent.codomain ?reverse (!t) let restrict t l = (t := Persistent.restrict (!t) l) let substract t l = (t := Persistent.substract (!t) l) end module String_map = Make (struct type t = string let compare = Pervasives.compare end) module Int_map = Make (struct type t = int let compare = Pervasives.compare end) end (* Destructive *) ocamlbricks-0.90+bzr456.orig/EXTRA/ooExtra.mli0000644000175000017500000000231713175721005017735 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) class virtual destroy_methods : unit -> object method add_destroy_callback : unit Lazy.t -> unit method private destroy : unit method mrproper : Thunk.lifo_unit_protected_container end module Gc_sync : sig val finalizer : (int -> unit) -> oid:int -> finalizer_hook:'a -> unit val notify : int -> unit class ['a] t : ?destroy:(int -> unit) -> 'a -> object method get : 'a method set : 'a -> unit end val ref : ?destroy:(int -> unit) -> 'a -> 'a t end ocamlbricks-0.90+bzr456.orig/EXTRA/setExtra.ml0000644000175000017500000001111713175721005017740 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../EXTRA/setExtra.mli" ;; module Extend = functor (S:Set.S) -> struct include S let copy (s : t) : t = fold add s empty let of_list ?(acc=empty) (xs : elt list) : t = List.fold_left (fun m e -> add e m) acc xs let of_lists (xss : elt list list) : t = match xss with | [] -> empty | xs::xss -> let t0 = of_list xs in List.fold_left (fun acc xs -> of_list ~acc xs) t0 xss let to_list ?(acc=[]) ?(reverse=false) (m : t) = let acc = if reverse then (List.rev acc) else acc in let l = fold (fun e xs -> e::xs) m acc in if reverse then List.rev l else l let uniq xs = to_list (of_list xs) end module Make = functor (Ord:Set.OrderedType) -> Extend (Set.Make (Ord)) module String_set = Extend (Set.Make (struct type t = string let compare = Pervasives.compare end)) module Int_set = Extend (Set.Make (struct type t = int let compare = Pervasives.compare end)) module Destructive = struct module type S = sig type elt type t val create : unit -> t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> unit val singleton : elt -> t val remove : elt -> t -> unit val union : t -> t -> unit val inter : t -> t -> unit val diff : t -> t -> unit val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> unit val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t val copy : t -> t val of_list : ?acc:t -> elt list -> t val to_list : ?acc:elt list -> ?reverse:bool -> t -> elt list end module Make (Ord : Set.OrderedType) = struct module Persistent = Make (Ord) type elt = Ord.t type t = Persistent.t ref let create () = ref Persistent.empty let is_empty t = Persistent.is_empty (!t) let mem x t = Persistent.mem x (!t) let add x t = (t := Persistent.add x !t) let singleton x = ref (Persistent.singleton x) let remove x t = (t := Persistent.remove x !t) let union t0 t1 = (t0 := Persistent.union (!t0) (!t1)) let inter t0 t1 = (t0 := Persistent.inter (!t0) (!t1)) let diff t0 t1 = (t0 := Persistent.diff (!t0) (!t1)) let compare t0 t1 = Persistent.compare (!t0) (!t1) let equal t0 t1 = Persistent.equal (!t0) (!t1) let subset t0 t1 = Persistent.subset (!t0) (!t1) let iter f t = Persistent.iter f (!t) let fold f t = Persistent.fold f (!t) let for_all f t = Persistent.for_all f (!t) let exists f t = Persistent.exists f (!t) let filter f t = (t := Persistent.filter f (!t)) let partition f t = let (s0,s1) = Persistent.partition f (!t) in (ref s0, ref s1) let cardinal t = Persistent.cardinal (!t) let elements t = Persistent.elements (!t) let min_elt t = Persistent.min_elt (!t) let max_elt t = Persistent.max_elt (!t) let choose t = Persistent.choose (!t) let split x t = let (s0,b,s1) = Persistent.split x (!t) in (ref s0, b, ref s1) let copy t = ref (!t) let of_list ?acc l = let acc = match acc with None -> None | Some t -> Some (!t) in ref (Persistent.of_list ?acc l) let to_list ?acc ?reverse t = Persistent.to_list ?acc ?reverse (!t) end (* Make*) module String_set = Make (struct type t = string let compare = Pervasives.compare end) module Int_set = Make (struct type t = int let compare = Pervasives.compare end) end (* Destructive *) ocamlbricks-0.90+bzr456.orig/EXTRA/stringExtra.mli0000644000175000017500000001341613175721005020630 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009-2011 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Additional features for the standard module [String]. *) (** {2 Importing & copying} *) type blit_function = string -> int -> string -> int -> int -> unit val blitting : perform:(char -> int -> unit) -> blit_function val from_descr : ?blit:blit_function -> Unix.file_descr -> string val from_file : ?blit:blit_function -> string -> string val from_channel : ?blit:blit_function -> in_channel -> string val from_string : perform:(char -> int -> unit) -> string -> string (** {2 Searching indexes} *) val nth_index_from : string -> int -> char -> int -> int val nth_rindex_from : string -> int -> char -> int -> int val nth_index : string -> char -> int -> int val nth_rindex : string -> char -> int -> int val for_all : (char -> bool) -> string -> bool val for_all_i : (int -> char -> bool) -> string -> bool val exists : (char -> bool) -> string -> bool val exists_i : (int -> char -> bool) -> string -> bool val lexists : (char -> bool) -> string -> int option val rexists : (char -> bool) -> string -> int option (** {2 Relations} *) val is_prefix : string -> string -> bool (** {2 Extracting sub-strings} *) val tail : string -> int -> string val head : string -> int -> string val frame : string -> char -> int -> int -> string val frame_strict : string -> char -> int -> int -> string val rframe : string -> char -> int -> int -> string val rframe_strict : string -> char -> int -> int -> string (** {2 Counting} *) val count : string -> char -> int val count_and_last_index : string -> char -> int * int val count_and_last_two_indexes : string -> char -> int * int * int (** {2 Stripping} *) val not_blank : char -> bool val lstrip : string -> string val rstrip : string -> string val strip : string -> string val chop : string -> string (** {2 Considering as a char array} *) val init : int -> (int -> char) -> string val iteri : (int -> char -> 'a) -> string -> unit val iter2 : (char -> char -> 'a) -> string -> string -> unit val iteri2 : (int -> char -> char -> 'a) -> string -> string -> unit val map : (char -> char) -> string -> string val mapi : (int -> char -> char) -> string -> string val map2 : (char -> char -> char) -> string -> string -> string val mapi2 : (int -> char -> char -> char) -> string -> string -> string val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a val fold_lefti : (int -> 'a -> char -> 'a) -> 'a -> string -> 'a val fold_left2 : ('a -> char -> 'b -> 'a) -> 'a -> string -> 'b array -> 'a val fold_lefti2 : (int -> 'a -> char -> 'b -> 'a) -> 'a -> string -> 'b array -> 'a val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a val fold_righti : (int -> char -> 'a -> 'a) -> string -> 'a -> 'a val fold_right2 : (char -> 'a -> 'b -> 'b) -> string -> 'a array -> 'b -> 'b val fold_righti2 : (int -> char -> 'a -> 'b -> 'b) -> string -> 'a array -> 'b -> 'b (** {2 Splitting to char list} *) val to_charlist : string -> char list val of_charlist : char list -> string val expand : (char -> string option) -> string -> string val tr : char -> char -> string -> string val rm : char -> string -> string module Charlist : sig val assemble : char list -> string val disassemble_reversing : ?acc:char list -> string -> char list val assemble_reversing : ?length:int -> char list -> string end (** {2 Splitting to string list} *) val cut : ?n:int -> string -> string list val split : ?do_not_squeeze:unit -> ?d:char -> string -> string list val split_squeezing_blanks : ?blanks:char list -> string -> string list (** {2 Merging strings} *) val concat : ?blit:blit_function -> string list -> string val quote : ?l:string -> ?r:string -> string -> string val assemble_if_not_empty : prefix:string -> suffix:string -> string -> string val map_concat : ?sep:string -> ('a -> string) -> 'a list -> string val merge_fields : string -> int list -> string list -> string (** {2 Text} *) type word = string val ensure_cr_at_end : string -> string module Text : sig type t = string list type line = string val to_string : t -> string val of_string : ?do_not_squeeze:unit -> string -> t val from_file : ?do_not_squeeze:unit -> string -> t val grep : ?before:int -> ?after:int -> Str.regexp -> t -> t (* --- *) val merge_lines : ?sep:string -> int -> t -> t val collapse_and_split : ?do_not_squeeze:unit -> ?d:char -> t -> word list (* --- *) module Matrix : sig type t = word list list type line = word list val of_string : ?do_not_squeeze:[< `cr | `d | `neither ] -> ?d:char -> string -> t val to_string : ?d:string -> t -> string val from_file : ?do_not_squeeze:[< `cr | `d | `neither ] -> ?d:char -> string -> t end end val fmt : ?tab:int -> ?prefix:string -> ?count_all:unit -> ?width:int -> string -> string val tab : ?tab:int -> ?prefix:string -> string -> string val make_wide : string -> int -> string ocamlbricks-0.90+bzr456.orig/EXTRA/waitpid-c-wrapper.c0000644000175000017500000000633113175721005021314 0ustar lucaslucas/* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Daniele Terreni This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #include #include #include #include #include #include #include #include #include #include #include #include #include #define WAITPID_NAME "waitpid" typedef enum { WENOHANG, WEUNTRACED, WECONTINUE } waitpid_flag; typedef enum { WEUNCHANGED, WECONTINUED } process_status_arity_0_constructors; typedef enum { WEEXITED, WESIGNALED, WESTOPPED } process_status_arity_1_constructors; static int c_of_caml_waitpid_option(value ml_flag) { switch(Int_val(ml_flag)){ case WENOHANG: return WNOHANG; case WEUNTRACED: return WUNTRACED; #ifdef WIFCONTINUED case WECONTINUE: return WCONTINUED; #else case WECONTINUE: return 0; #endif default: assert(0); } } CAMLprim value waitpid_c (value ml_flag_list, value ml_child_pid) { int options = 0; pid_t child_pid = 0; pid_t wpid = 0; int status = 0; CAMLparam2(ml_flag_list, ml_child_pid); CAMLlocal3(flag, res, process_status); /* Retreiving the flag bit mask */ while(ml_flag_list != Val_emptylist){ flag = Field(ml_flag_list, 0); options = options | c_of_caml_waitpid_option(flag); ml_flag_list = Field(ml_flag_list, 1); } child_pid = Int_val(ml_child_pid); enter_blocking_section(); wpid = waitpid(child_pid, &status, options); leave_blocking_section(); if(wpid == -1){ uerror(WAITPID_NAME, Nothing); } else { res = alloc_tuple(2); Store_field(res, 0, Val_int(wpid)); if(wpid == 0){ /* Waitpid launched with WNOHANG option: no state change detected. Returning 0, WUNCHANGED */ Store_field(res, 1, Val_int(WEUNCHANGED)); } else{ int tag_value; int code; /* State change detected */ #ifdef WIFCONTINUED if (WIFCONTINUED(status)) { Store_field(res, 1, Val_int(WECONTINUED)); CAMLreturn(res); } else #endif if (WIFEXITED(status)){ tag_value = WEEXITED; code = WEXITSTATUS(status); } else if (WIFSIGNALED(status)) { tag_value = WESIGNALED; code = WTERMSIG(status); } else if (WIFSTOPPED(status)) { tag_value = WESTOPPED; code = WSTOPSIG(status); } else { uerror(WAITPID_NAME, Val_unit); } process_status = caml_alloc(1,tag_value); Store_field(process_status, 0, Val_int(code)); Store_field(res, 1, process_status); } } CAMLreturn(res); } ocamlbricks-0.90+bzr456.orig/EXTRA/filenameExtra.ml0000644000175000017500000000744613175721005020737 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** [add_extension_if_absent filename ext] append to the string [filename] the extension [ext] but only if the filename has no already an extension. This operation just works on strings and doesn't modify anything in the filesystem. {b Example}: {[# add_extension_if_absent "foo" "txt";; : string = "foo.txt" # add_extension_if_absent "foo.c" "txt";; : string = "foo.c" ]}*) let add_extension_if_absent filename ext = try let _ = (Filename.chop_extension filename) in filename (* because the filename already has an extension *) with _ -> (filename^"."^ext) (* because the filename has no extension *) (** {b Example}: {[# get_extension "/tmp/aaa.bbb.ccc" ;; : string option = Some "ccc" # get_extension "/tmp/aaa" ;; : string option = None ]}*) let get_extension ?with_dot filename = try let x = (Filename.chop_extension filename) in let a = String.length x in let b = String.length filename in (match with_dot with | None -> Some (String.sub filename (a+1) (b-a-1)) | Some () -> Some (String.sub filename a (b-a)) ) with _ -> None (** The default is the empty string. {b Examples}: {[# get_extension_or_default "foo" ;; : string = "" # get_extension_or_default "foo.txt" ;; : string = "txt" # get_extension_or_default ~with_dot:() "foo.txt" ;; : string = ".txt" ]} *) let get_extension_or_default ?with_dot ?(default="") filename = match (get_extension ?with_dot filename) with | None -> default | Some r -> r (** [Filename.concat] generalized to lists. {b Examples}: {[# concat_list ["aaa";"bbb";"ccc"] ;; : string = "aaa/bbb/ccc" ]} *) let rec concat_list = function [] -> "" | x::[] -> x | x::xs -> Filename.concat x (concat_list xs) let temp_dir ?temp_dir ?(prefix="") ?(suffix="") ?(perm=0o755) () = let result = Filename.temp_file ?temp_dir prefix suffix in Sys.remove result; Unix.mkdir result perm; Unix.chmod result perm; (* Yes, we insist because it seems necessary... *) result let to_absolute ?parent x = if not (Filename.is_relative x) then x else let parent = match parent with | None -> Sys.getcwd () | Some p -> if Filename.is_relative p then failwith "to_absolute: non-absolute parent provided" else p in Filename.concat parent x (** Note that the empty string became "." *) let make_explicit x = if Filename.is_implicit x then Filename.concat "./" x else x let remove_trailing_slashes_and_dots = let make_explicit_alias = make_explicit in fun ?make_explicit x -> let y = if make_explicit=Some () then make_explicit_alias x else x in let rec loop y = if (y="/.") || (y="/") then "/" else if Filename.check_suffix y "/." then loop (Filename.chop_suffix y "/.") else if Filename.check_suffix y "/" then loop (Filename.chop_suffix y "/") else y in loop y let append_trailing_unique_slash ?make_explicit x = let y = remove_trailing_slashes_and_dots ?make_explicit x in if not (Filename.check_suffix y "/") then Filename.concat y "" else y ocamlbricks-0.90+bzr456.orig/META0000644000175000017500000000037313175721005015377 0ustar lucaslucasname="ocamlbricks" version="trunk" descriton = "A general-purpose library of reusable small code bricks" requires = "lablgtk2 unix str" archive(syntax,preprocessor) = "-thread" archive(byte,mt) = "ocamlbricks.cma" archive(native) = "ocamlbricks.cmxa" ocamlbricks-0.90+bzr456.orig/BASE/0000755000175000017500000000000013175721005015435 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/BASE/mrproper.mli0000644000175000017500000000416713175721005020016 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Register actions to perform exiting the program or destroying a temporary structure. On the one hand, a definition as the following could be written at the beginning of a program: {[ let exit = Mrproper.exit ;; ]} and could be used for exiting the program. On the other hand, anywhere in the program you could register some actions in order to leave the program cleanly, as for instance: {[ let filename = temp_file ~perm:0o755 ~suffix:".sh" () in let () = Mrproper.register_lazy (lazy (Unix.unlink filename)) in ...]} Note that actions are internally registered in a {b stack} and are thus performed in the reversed order with respect to the registration (insertion). *) (** Push a thunk into the global stack of thunks. *) val register_thunk : ?unprotect:unit -> ?one_shot:unit -> unit Thunk.t -> Thunk.id (** Push a lazy action into the global stack of thunks. Lazy actions are forced to be one-shot: when unprotected, the thunk will not re-raise the same exception forcing the thunk execution twice. *) val register_lazy : ?unprotect:unit -> unit Lazy.t -> Thunk.id (** Exit the program performing all registered actions in the global stack.*) val exit : int -> 'a (** Perform the list (stack) of registered actions. *) val apply : unit -> unit (** Low level access to the inner global stack: *) val as_stack : unit -> (unit Thunk.t * Thunk.linear) Container.Stack_with_identifiers.t ocamlbricks-0.90+bzr456.orig/BASE/fix.ml0000644000175000017500000000540513175721005016561 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** Basic fix point operators. {b Example}: {[# let fact self = fun x -> if (x=0) then 1 else x * (self (x-1)) ;; val fact : (int -> int) -> int -> int = # let f = fix fact;; val f : int -> int = # f 5;; : int = 120 ]}*) let rec fix f = f (fun x -> (fix f) x) (** Fix point operator for making function requiring a parameter (the "{e environment}"). {b Example}: {[# let fact y self = fun x -> if (x=0) then y else x * (self y (x-1)) ;; val fact : int -> (int -> int -> int) -> int -> int = # let f y = (efix fact y) ;; val f : int -> int -> int = # f 2 5;; : int = 240 # f 3 5;; : int = 360 ]}*) let rec efix f e = (f e) (fun y x -> (efix f y) x) (** Fix point operator with an environment and a treatment (a "{e cure}") to perform {b before} each recursive call. The typical example is the "memoisation" cure useful for making memoised functions defined by a recursive definition (each recursive call must share the same hash table). {b Example}: {[# let fact y self = fun x -> if (x=0) then y else x * (self y (x-1)) ;; val fact : int -> (int -> int -> int) -> int -> int = (* The cure change the sign at the end of each iteration *) # let f y = (ecfix (fun g x -> (g x)*(-1)) fact y) ;; val f : int -> int -> int = # f 2 3;; : int = 12 (* because of an even number (4) of iterations *) # f 2 4;; : int = -48 (* because of an odd number (5) of iterations *) # f 2 5;; : int = 240 (* because of an even number (6) of iterations *) (* Tracing the unfolding *) # let f y = (Fix.ecfix (fun g x -> (print_int x; print_newline ()); (g x)*(-1)) fact y) ;; # f 2 5;; 5 4 3 2 1 0 : int = 240 ]}*) let rec ecfix c f e = (fun g -> c ((f e) g)) (fun y x -> (ecfix c f y) x) (** Find the fixpoint using the polymorphic equality: *) let find ?(equals=(=)) ?(loops_limit=max_int) f x0 = let rec loop i x0 = let x1 = f x0 in if (equals x0 x1) || (i>=loops_limit) then x1 else loop (i+1) x1 in loop 1 x0 ocamlbricks-0.90+bzr456.orig/BASE/sugar.ml0000644000175000017500000000520513175721005017112 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Basic shortcuts and syntactic sugar. *) (** {2 Pipelines of functions } *) (** Mnemonic (unix-reminiscent) and funny aliases for function composition. *) (** Make a pipeline of functions. It's simply the function composition, of course, not a real pipeline (stream composition), so keep an eye on memory allocation. *) let (||) f g = fun x -> g (f x);; (** Put a value into a pipelines of functions *) let (=>) x f = (f x);; (** {b Example} {[ "ls" => ( SSys.run || fst || SString.toList ) ;; ]} {b Working with tuples} *) let identity = fun x -> x;; let id = identity ;; let (@@) f g = fun (x,y) -> ((f x),(g y));; let curry f = fun x y -> f (x,y) ;; let uncurry f = fun (x,y) -> f x y ;; (** {b Example}. Definition of the pattern matching function : {[ let match_pattern pat str : bool = let string_match (p,s) = (Str.string_match p s 0) in (pat,str) => ( (Str.regexp\@\@identity) || string_match ) ;; ]} In this example, pat is given to Str.regexp and str is given to identity. {b Example}. Remove the element with the given index: {[ let rmindex l i = (l,l) => ((identity\@\@indexes) || (uncurry List.combine) || (List.filter (fun (x,j) ->j<>i)) || List.split || fst) ;;]}*) (** {2 Default for ['a option]} *) (** Short cut for quickly open an optional value. {b Example} {[# let x = Some 4 ;; val x : int option = Some 4 ]} Now you can write: {[# x |=> 7 ;; : int = 4 ]} instead of write: {[ match x with Some v -> v | None -> 7;; ]} *) let (|=>) (x:'a option) (default:'a) = match x with Some v -> v | None -> default;; (** {2 Other shortcuts} *) (** Other recurrent shortcuts. *) (** Equivalent to [function () -> ()]. *) let nothing = function () -> () ;; (** Equivalent to [()]. *) let skip = () ;; (** Equivalent to [int]. *) type identifier = int;; (** A {e filter} is function that transform elements in the same domain (endo-function). *) type 'a filter = 'a -> 'a ;; ocamlbricks-0.90+bzr456.orig/BASE/sugar.mli0000644000175000017500000000226113175721005017262 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Basic shortcuts and syntactic sugar. *) val ( || ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c val ( => ) : 'a -> ('a -> 'b) -> 'b val identity : 'a -> 'a val id : 'a -> 'a val ( @@ ) : ('a -> 'b) -> ('c -> 'd) -> 'a * 'c -> 'b * 'd val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c val ( |=> ) : 'a option -> 'a -> 'a val nothing : unit -> unit val skip : unit type identifier = int type 'a filter = 'a -> 'a ocamlbricks-0.90+bzr456.orig/BASE/log_builder.ml0000644000175000017500000002663213175721005020267 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Jean-Vincent Loddo: migration from marionnet, synchronization, functorization * - Luca Saiu: Original code in marionnet/log.ml *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) #load "include_type_definitions_p4.cmo";; INCLUDE DEFINITIONS "../BASE/log_builder.mli" ;; (* We will use an extended version of Mutex: *) module Mutex = MutexExtra.Extended_Mutex (* The global structures are not created at loading time (except global_mutex) but only if needed, at the first functor application. *) let global_structures = ref None let global_mutex = Mutex.create () let get_global_structures () = Mutex.with_mutex global_mutex (fun () -> match !global_structures with | None -> let ht = Hashtbl.create 51 in let ht_mutex = Mutex.create () in let stdout_mutex = Mutex.create () in let stderr_mutex = Mutex.create () in let () = Hashtbl.add ht "/dev/stdout" (stdout, stdout_mutex) in let () = Hashtbl.add ht "/dev/stderr" (stderr, stderr_mutex) in let tuple = (ht, ht_mutex, stdout_mutex, stderr_mutex) in let () = (global_structures := Some tuple) in tuple | Some tuple -> tuple ) (* The out channels are shared by all threads of the program. Hence, there is a mutex per channel. `file "/dev/stdout" (resp. `file "/dev/stderr") is equivalent to `stdout (resp. `stderr). *) let get_out_channel log_channel = let (ht, ht_mutex, stdout_mutex, stderr_mutex) = get_global_structures () in let out_channel_and_mutex_of_filename fname = (try Hashtbl.find ht fname with Not_found -> begin let out_channel = open_out fname in let mutex = Mutex.create () in (Hashtbl.add ht fname (out_channel,mutex)); (out_channel, mutex) end) in match log_channel with | `stdout -> (stdout, stdout_mutex) | `stderr -> (stderr, stderr_mutex) | `file fname -> Mutex.apply_with_mutex (ht_mutex) (out_channel_and_mutex_of_filename) fname module Make (Tuning:sig val verbosity : int (* dynamic *) val debug_level : unit -> int (* dynamic *) val log_channel : log_channel (* static *) val synchronized : bool (* static *) end) : Result = struct (** We redefine Tuning in order to provide it a modifiable state: *) module Tuning = struct module Variable = Stateful_modules.Thread_shared_variable module Verbosity = Variable (struct type t = int let name=None end) module Debug_level = Variable (struct type t = unit -> int let name=None end) let () = begin (* Variables initialization: *) Verbosity.set Tuning.verbosity; Debug_level.set Tuning.debug_level; end let verbosity = Verbosity.extract let debug_level () = Debug_level.extract () () let is_log_enabled ?v () = match v with | None -> (debug_level ()) >= (verbosity ()) | Some v -> (debug_level ()) >= v let log_channel = Tuning.log_channel let synchronized = Tuning.synchronized module Set = struct let verbosity = Verbosity.set let debug_level = Debug_level.set end end (* Tuning redefinition. *) let (out_channel, mutex) = get_out_channel Tuning.log_channel let apply_with_mutex (f:'a -> 'b) (x:'a) : 'b = Mutex.apply_with_mutex (mutex) f x let unprotected_test_is_log_disable ?v ?(force=false) () = not ((Tuning.is_log_enabled ?v ()) || force) let printf_unsynchronized ?(banner=true) (frmt:('a, out_channel, unit) format) : 'a = let () = match banner with | false -> () | true -> let thread_id = Thread.id (Thread.self ()) in let pid = Unix.getpid () in let prefix = Printf.sprintf "[%d.%d]: " pid thread_id in Printf.kfprintf flush out_channel "%s" prefix in Printf.kfprintf flush out_channel frmt (* Take a format string and either use it for Printf.printf, or use it for a dummy printf-like function which does nothing, according to whether we're in debug mode or not: *) (* printf0 *) let printf ?v ?force ?banner frmt = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt) () else printf_unsynchronized ?banner frmt let printf1 ?v ?force ?banner frmt x1 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1) () else printf_unsynchronized ?banner frmt x1 let printf2 ?v ?force ?banner frmt x1 x2 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2) () else printf_unsynchronized ?banner frmt x1 x2 let printf3 ?v ?force ?banner frmt x1 x2 x3 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3) () else printf_unsynchronized ?banner frmt x1 x2 x3 let printf4 ?v ?force ?banner frmt x1 x2 x3 x4 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 x4 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3 x4) () else printf_unsynchronized ?banner frmt x1 x2 x3 x4 let printf5 ?v ?force ?banner frmt x1 x2 x3 x4 x5 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 x4 x5 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5) () else printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 let printf6 ?v ?force ?banner frmt x1 x2 x3 x4 x5 x6 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 x4 x5 x6 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6) () else printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 let printf7 ?v ?force ?banner frmt x1 x2 x3 x4 x5 x6 x7 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 x4 x5 x6 x7 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 x7) () else printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 x7 let printf8 ?v ?force ?banner frmt x1 x2 x3 x4 x5 x6 x7 x8 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 x4 x5 x6 x7 x8 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 x7 x8) () else printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 x7 x8 let printf9 ?v ?force ?banner frmt x1 x2 x3 x4 x5 x6 x7 x8 x9 = if unprotected_test_is_log_disable ?v ?force () then Printf.ifprintf out_channel frmt x1 x2 x3 x4 x5 x6 x7 x8 x9 else if Tuning.synchronized then apply_with_mutex (fun () -> printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 x7 x8 x9) () else printf_unsynchronized ?banner frmt x1 x2 x3 x4 x5 x6 x7 x8 x9 let print_exn ?v ?force ?banner ?(prefix="") ?suffix e = match suffix with | None -> printf2 ?v ?force ?banner "%s%s\n" prefix (Printexc.to_string e) | Some suffix -> printf3 ?v ?force ?banner "%s%s%s\n" prefix (Printexc.to_string e) suffix module Unprotected = struct let printf ?v ?(force=false) ?banner frmt = if force || (Tuning.is_log_enabled ?v ()) then printf_unsynchronized ?banner frmt else Printf.ifprintf out_channel frmt (* do nothing (with type 'a) *) let print_exn ?v ?force ?banner ?(prefix="") ?suffix e = match suffix with | None -> printf ?v ?force ?banner "%s%s\n" prefix (Printexc.to_string e) | Some suffix -> printf ?v ?force ?banner "%s%s%s\n" prefix (Printexc.to_string e) suffix end (* Unprotected *) end (* Make *) module Make_simple (Tuning:sig val is_log_enabled : unit -> bool end) = Make (struct let verbosity = 1 let debug_level () = if Tuning.is_log_enabled () then 1 else 0 let log_channel = `stderr let synchronized = true end) (** Wrappers providing a logged version of functions defined elsewhere. *) module Extend_with_wrappers (Log : Result) = struct include Log (** Wrapper for [UnixExtra.system_or_fail]: run system with the given argument, and raise exception in case of failure; return unit on success. Commands are automatically logged in debug mode. Furthermore, when debugging is not enable, a command redirection (/bin/sh compatible, i.e. 1>/dev/null 2>/dev/null) is automatically appended to the command. In order to prevent this behaviour, the function provides the optional parameters ?hide_output and ?hide_errors: setting both these parameters to false, you ensure that nothing will be appended to the command (in debug mode or not). *) let system_or_fail ?on_error ?hide_output ?hide_errors (command_line:string) = let extract_hide_decision h = match h with | None -> not (Tuning.is_log_enabled ()) | Some decision -> decision in let hide_output = extract_hide_decision hide_output in let hide_errors = extract_hide_decision hide_errors in let () = Log.printf1 "Executing: %s\n" command_line in try UnixExtra.system_or_fail ~hide_output ~hide_errors command_line with e -> begin (match on_error with | None -> () | Some command -> try UnixExtra.system_or_fail ~hide_output ~hide_errors command with _ -> () ); raise e end (** Equivalent to [ignore (Unix.system command_line)] but with logging features. Notice that if the command_line terminates with '&' (background), no exceptions will be raised. Thus, using '&', there is no effect in setting [~force:true], because the shell well exit in any case. However, Log.system_or_ignore is preferable with respect to [(ignore (Unix.system command_line))] because it shows shell errors only in the debug mode. *) let system_or_ignore ?on_error ?hide_output ?hide_errors command_line = try system_or_fail ?on_error ?hide_output ?hide_errors command_line with e -> begin let fmt = format_of_string "Ignoring exception: %s\n" in let msg = Printexc.to_string e in (match hide_errors with | None -> Log.printf1 fmt msg | Some false -> Log.printf1 ~force:true fmt msg | Some true -> () ) end let print_backtrace () = Log.printf1 "Backtrace:\n%s\n" (StringExtra.tab ~tab:2 (Printexc.get_backtrace ())) end ocamlbricks-0.90+bzr456.orig/BASE/mrproper.ml0000644000175000017500000000217513175721005017642 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) let global_object = new Thunk.lifo_unit_protected_container () let register_thunk = global_object#register_thunk let register_lazy = global_object#register_lazy let apply = global_object#apply let remove = global_object#remove let get = global_object#get let as_stack () = global_object#as_stack let exit (code) = let () = apply () in (Pervasives.exit code) ocamlbricks-0.90+bzr456.orig/BASE/ocamlbricks_log.mli0000644000175000017500000000506513175721005021300 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2011 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) val enable : unit -> unit val disable : unit -> unit val printf : ?v:int -> ?force:bool -> ?banner:bool -> ((unit, out_channel, unit) format) -> unit val printf1 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> unit, out_channel, unit) format) -> 'a -> unit val printf2 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> unit, out_channel, unit) format) -> 'a -> 'b -> unit val printf3 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> unit val printf4 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> unit val printf5 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> unit val printf6 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> 'f -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> unit val printf7 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> unit val print_exn : ?v:int -> ?force:bool -> ?banner:bool -> ?prefix:string -> ?suffix:string -> exn -> unit module Unprotected: sig val printf : ?v:int -> ?force:bool -> ?banner:bool -> (('a, out_channel, unit) format) -> 'a val print_exn : ?v:int -> ?force:bool -> ?banner:bool -> ?prefix:string -> ?suffix:string -> exn -> unit end module Tuning : sig val verbosity : unit -> int val debug_level : unit -> int val is_log_enabled : ?v:int -> unit -> bool val log_channel : Log_builder.log_channel val synchronized : bool module Set : sig val verbosity : int -> unit val debug_level : (unit -> int) -> unit end end ocamlbricks-0.90+bzr456.orig/BASE/log_builder.mli0000644000175000017500000001707313175721005020437 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Jean-Vincent Loddo: migration from marionnet, synchronization, functorization * - Luca Saiu: Original code in marionnet/log.ml *) (** Facility for tracing program activities, specially using threads. Essentially, this module provides a set of functions [Log.printf], where N is the number of arguments following the format. These functions print your messages only when the current debugging level of the application rises above ([>=]) the verbosity. Two ore more modules may be built on the same {!Log_builder.log_channel}. Actually: - an internal global hash table register the associations [(file,out_channel)] - a mutex per out_channel is created in order to preserve atomicity of each printing. {b Example}: {[(* Define your log modules: *) module Log1 = Log_builder.Make (struct let debug_level () = ... (* explain here where to get the current value of the debugging level; this value must be greater or equal to the verbosity, otherwise do nothing *) let verbosity = 1 (* the default value of verbosity for printing functions *) let log_channel = `stderr (* put messages here *) let synchronized = true (* using threads *) end);; module Log2 = Log_builder.Make (struct let debug_level () = ... let verbosity = 2 let log_channel = `stderr (* share the same channel of Log1 *) let synchronized = true end);; (* Put calls somewhere in your code : *) ... Log1.printf1 "%s\n" value; (* really printed when debug level >= 1 *) ... Log2.printf1 "%s\n" value; (* really printed when debug level >= 2 *) ... ]} *) (** Data type representing the output channel where the messages will be written. *) type log_channel = [ `stdout | `stderr | `file of string ] (** The type of the `printf' resulting function. This naming is useful to define functions with a `log_printf' parameter. *) type 'a printf = ?v:int -> ?force:bool -> ?banner:bool -> ('a, out_channel, unit) format -> 'a (** The signature of the module resulting from functors' applications. *) module type Result = sig (** The banner is a complement prepended to your message. It contains informations about the program and the thread which are executed. {b Example:} {[# module Log = Log.Make_simple (struct let is_log_enabled () = true end) ;; # Log.printf1 "The result is %d\n" 42 ;; toplevel 13920 [thread 0]: The result is 42 : unit = () # Log.printf1 ~banner:false "The result is %d\n" 42 ;; The result is 42 : unit = () ]}*) val printf : ?v:int -> ?force:bool -> ?banner:bool -> ((unit, out_channel, unit) format) -> unit val printf1 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> unit, out_channel, unit) format) -> 'a -> unit val printf2 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> unit, out_channel, unit) format) -> 'a -> 'b -> unit val printf3 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> unit val printf4 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> unit val printf5 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> unit val printf6 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> 'f -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> unit val printf7 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> unit val printf8 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> unit val printf9 : ?v:int -> ?force:bool -> ?banner:bool -> (('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> unit, out_channel, unit) format) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> unit val print_exn : ?v:int -> ?force:bool -> ?banner:bool -> ?prefix:string -> ?suffix:string -> exn -> unit module Unprotected:sig val printf : ?v:int -> ?force:bool -> ?banner:bool -> (('a, out_channel, unit) format) -> 'a val print_exn : ?v:int -> ?force:bool -> ?banner:bool -> ?prefix:string -> ?suffix:string -> exn -> unit end module Tuning:sig val verbosity : unit -> int val debug_level : unit -> int val is_log_enabled : ?v:int -> unit -> bool val log_channel : log_channel val synchronized : bool module Set : sig val verbosity : int -> unit val debug_level : (unit -> int) -> unit end end end (** {2 General construction} *) (** Build a module with printing facilities, providing a "tuning" module which defines four parameters: - the [threshold] starting from the printing is really performed - the thunk [get_current_verbosity] providing the current level of verbosity of the application - the {!Log_builder.log_channel} where messages will be put in - the flag [synchronized] indicating if threads are in use, hence if synchronizations are required to preserve the atomicity of printing operations. *) module Make : functor (Tuning : sig val verbosity : int val debug_level : unit -> int val log_channel : log_channel val synchronized : bool end) -> Result (** {2 Simplified construction} *) (** Build a kit of printing functions using just one parameter, the thunk [is_log_enabled], that simply indicates if the debugging is currently activated in the application. Using this functor, the output channel is set to [stderr] and the synchronization is performed. *) module Make_simple : functor (Tuning : sig val is_log_enabled : unit -> bool end) -> Result (** {b Example}: {[ (* Initialized later, by Global_options, in order to break the ciclic dependency: *) module Self = Log_builder.Make (struct let debug_level () = 0 (* the debug_level must be greater or equal to the verbosity, otherwise do nothing *) let verbosity = 1 (* the default value of verbosity for printing functions *) let log_channel = `stderr (* put messages here *) let synchronized = true (* using threads *) end);; include Log_builder.Extend_with_wrappers (Self) ;; ]} *) module Extend_with_wrappers : functor (Log : Result) -> sig include Result val system_or_fail : ?on_error:UnixExtra.command -> ?hide_output:bool -> ?hide_errors:bool -> UnixExtra.command -> unit val system_or_ignore : ?on_error:UnixExtra.command -> ?hide_output:bool -> ?hide_errors:bool -> UnixExtra.command -> unit val print_backtrace : unit -> unit end ocamlbricks-0.90+bzr456.orig/BASE/argv.mli0000644000175000017500000002355013175721005017104 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** High-level impure but cool API for the standard module [Arg]. *) (** List of available registering functions with their codomain: {[val register_usage_msg : string -> unit val register_h_option_as_help : unit -> unit val register_unit_option : .. -> unit option ref val register_bool_option : .. -> bool option ref val register_string_option : .. -> string option ref val register_filename_option : .. -> string option ref val register_directory_option : .. -> string option ref val register_enum_option : .. -> string option ref val register_int_option : .. -> int option ref val register_float_option : .. -> float option ref val register_string_optional_argument : .. -> string option ref val register_string_argument : .. -> string ref val register_string_list0_argument : .. -> string list ref val register_string_list1_argument : .. -> string list ref val register_bool_optional_argument : .. -> ?default:bool option -> bool option ref val register_bool_argument : .. -> bool ref val register_bool_list0_argument : .. -> bool list ref val register_bool_list1_argument : .. -> bool list ref val register_int_optional_argument : .. -> int option ref val register_int_argument : .. -> int ref val register_int_list0_argument : .. -> int list ref val register_int_list1_argument : .. -> int list ref val register_float_optional_argument : .. -> float option ref val register_float_argument : .. -> float ref val register_float_list0_argument : .. -> float list ref val register_float_list1_argument : .. -> ?error_msg:error_msg -> float list ref val register_filename_optional_argument : .. -> string option ref val register_filename_argument : .. -> string ref val register_filename_list0_argument : .. -> string list ref val register_filename_list1_argument : .. -> string list ref ]} {b Example}: {[(* Registering usage: *) let () = Argv.register_usage_msg "Usage: myprogram [OPTIONS] LENGTH [FLAGS..] POWERS[POWERS..] FILE[FILES..]\nOptions:" ;; (* Registering options: *) let option_x : unit option ref = Argv.register_unit_option "x" ~doc:"very useful option -x" () ;; let option_y : unit option ref = Argv.register_unit_option "y" () ;; let option_z : bool option ref = Argv.register_bool_option "z" () ;; let option_s = Argv.register_string_option "s" ~tests:[(((<>)"none"), "not none please for the option `-s'")] () ;; let option_t = Argv.register_enum_option "t" ~admissible_args:["BLACK"; "WHITE"] ~doc:"very useful option -t" () ;; let option_f = Argv.register_filename_option "f" ~w:() ~r:() ~b:() ~doc:"very useful option -f" () ;; let option_d = Argv.register_directory_option "d" ~w:() ~doc:"very useful option -d" () ;; let () = Argv.register_h_option_as_help () ;; (* Registering arguments: *) let length = Argv.register_float_argument () ;; let flags = Argv.register_bool_list0_argument () ;; let powers = Argv.register_int_list1_argument () ;; let files = Argv.register_filename_list1_argument ~r:() ~f:() () ;; let main = begin (* Parse the command line (Sys.argv). The program will exit if something goes wrong parsing the command line: *) Argv.parse (); (* At this point all involved references have been updated: *) let () = if !option_x = Some () then begin Printf.printf "Not so useful option. Exiting ;-)\n"; exit 0; end in ... end ;; ]} Now, for instance, at command line: {[$ myprogram -x -y -z trued -s none 3.14 42 /etc/a[ln]* myprogram: wrong argument `trued'; option `-z' expects a boolean. Usage: myprogram [OPTIONS] LENGTH FLAGS.. POWERS[POWERS..] FILE[FILES..] Options: -x very useful option -x -y undocumented -z BOOL undocumented -s STRING undocumented -t {BLACK|WHITE} very useful option -t -f FILE very useful option -f -d DIR very useful option d -h Display this list of options -help Display this list of options --help Display this list of options (* end of example *) ]} *) type error_msg = string val register_usage_msg : string -> unit val tuning : ?no_error_location_parsing_arguments:unit -> ?no_usage_on_error_parsing_arguments:unit -> unit -> unit (** {2 Options without argument} *) val register_unit_option : string -> ?aliases:string list -> ?doc:string -> ?default:unit option -> ?toggle:unit -> unit -> unit option ref (** {2 Options with argument} *) val register_bool_option : string -> ?aliases:string list -> ?arg_name_in_help:string -> ?doc:string -> ?default:bool option -> unit -> bool option ref val register_string_option : string -> ?aliases:string list -> ?tests:((string -> bool) * error_msg) list -> ?arg_name_in_help:string -> ?doc:string -> ?default:string option -> unit -> string option ref val register_filename_option : string -> ?aliases:string list -> ?r:unit -> ?w:unit -> ?x:unit -> ?follow:unit -> ?f:unit -> ?d:unit -> ?c:unit -> ?b:unit -> ?h:unit -> ?p:unit -> ?socket:unit -> ?error_msg:string -> ?tests:((string -> bool) * error_msg) list -> ?arg_name_in_help:string -> ?doc:string -> ?default:string option -> unit -> string option ref val register_directory_option : string -> ?aliases:string list -> ?r:unit -> ?w:unit -> ?x:unit -> ?error_msg:string -> ?tests:((string -> bool) * error_msg) list -> ?arg_name_in_help:string -> ?doc:string -> ?default:string option -> unit -> string option ref val register_enum_option : string -> ?aliases:string list -> admissible_args:string list -> ?doc:string -> ?default:string option -> unit -> string option ref val register_int_option : string -> ?aliases:string list -> ?tests:((int -> bool) * error_msg) list -> ?arg_name_in_help:string -> ?doc:string -> ?default:int option -> unit -> int option ref val register_float_option : string -> ?aliases:string list -> ?tests:((float -> bool) * error_msg) list -> ?arg_name_in_help:string -> ?doc:string -> ?default:float option -> unit -> float option ref val register_h_option_as_help : unit -> unit (** {2 String arguments } *) val register_string_optional_argument : ?tests:((string -> bool) * error_msg) list -> ?default:string option -> unit -> string option ref val register_string_argument : ?tests:((string -> bool) * error_msg) list -> ?error_msg:error_msg -> unit -> string ref val register_string_list0_argument : ?tests:((string -> bool) * error_msg) list -> unit -> string list ref val register_string_list1_argument : ?tests:((string -> bool) * error_msg) list -> ?error_msg:error_msg -> unit -> string list ref (** {2 Bool arguments } *) val register_bool_optional_argument : ?default:bool option -> unit -> bool option ref val register_bool_argument : ?error_msg:error_msg -> unit -> bool ref val register_bool_list0_argument : unit -> bool list ref val register_bool_list1_argument : ?error_msg:error_msg -> unit -> bool list ref (** {2 Int arguments } *) val register_int_optional_argument : ?tests:((int -> bool) * error_msg) list -> ?default:int option -> unit -> int option ref val register_int_argument : ?tests:((int -> bool) * error_msg) list -> ?error_msg:error_msg -> unit -> int ref val register_int_list0_argument : ?tests:((int -> bool) * error_msg) list -> unit -> int list ref val register_int_list1_argument : ?tests:((int -> bool) * error_msg) list -> ?error_msg:error_msg -> unit -> int list ref (** {2 Float arguments } *) val register_float_optional_argument : ?tests:((float -> bool) * error_msg) list -> ?default:float option -> unit -> float option ref val register_float_argument : ?tests:((float -> bool) * error_msg) list -> ?error_msg:error_msg -> unit -> float ref val register_float_list0_argument : ?tests:((float -> bool) * error_msg) list -> unit -> float list ref val register_float_list1_argument : ?tests:((float -> bool) * error_msg) list -> ?error_msg:error_msg -> unit -> float list ref (** {2 Filename arguments } *) val register_filename_optional_argument : ?r:unit -> ?w:unit -> ?x:unit -> ?follow:unit -> ?f:unit -> ?d:unit -> ?c:unit -> ?b:unit -> ?h:unit -> ?p:unit -> ?socket:unit -> ?error_msg:string -> ?tests:((string -> bool) * error_msg) list -> ?default:string option -> unit -> string option ref val register_filename_argument : ?r:unit -> ?w:unit -> ?x:unit -> ?follow:unit -> ?f:unit -> ?d:unit -> ?c:unit -> ?b:unit -> ?h:unit -> ?p:unit -> ?socket:unit -> ?error_msg:string -> ?tests:((string -> bool) * error_msg) list -> unit -> string ref val register_filename_list0_argument : ?r:unit -> ?w:unit -> ?x:unit -> ?follow:unit -> ?f:unit -> ?d:unit -> ?c:unit -> ?b:unit -> ?h:unit -> ?p:unit -> ?socket:unit -> ?error_msg:string -> ?tests:((string -> bool) * error_msg) list -> unit -> string list ref val register_filename_list1_argument : ?r:unit -> ?w:unit -> ?x:unit -> ?follow:unit -> ?f:unit -> ?d:unit -> ?c:unit -> ?b:unit -> ?h:unit -> ?p:unit -> ?socket:unit -> ?error_msg:string -> ?tests:((string -> bool) * error_msg) list -> unit -> string list ref (** {2 Parsing functions } *) val parse_argv : string array -> unit val parse : ?exit_with_errno:int -> unit -> unit ocamlbricks-0.90+bzr456.orig/BASE/argv.ml0000644000175000017500000005552713175721005016744 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* ----------------------------------------- Module's hidden state ----------------------------------------- *) type error_msg = string type argument_spec = | Optional of (string -> unit) | Mandatory of (string -> unit) * error_msg | List0 of (string -> unit) | List1 of (string -> unit) * error_msg | Optional_last of (string -> unit) | List0_last of (string -> unit) | List1_last of (string -> unit) * error_msg let options_register = ref [] ;; let arguments_register : argument_spec list ref = ref [] ;; let usage_msg = ref "Usage: " ;; module Tuning = struct let no_error_location_parsing_arguments = ref None let no_usage_on_error_parsing_arguments = ref None end let tuning ?no_error_location_parsing_arguments ?no_usage_on_error_parsing_arguments () = begin Tuning.no_error_location_parsing_arguments := no_error_location_parsing_arguments; Tuning.no_usage_on_error_parsing_arguments := no_usage_on_error_parsing_arguments; end (* ----------------------------------------- Usage ----------------------------------------- *) let register_usage_msg x = usage_msg := x ;; let register_h_option_as_help () = let spec_list () = Arg.align (List.rev !options_register) in let doc = " Display this list of options" in let spec = (("-h"), Arg.Unit (fun () -> Printf.printf "%s" (Arg.usage_string (spec_list ()) !usage_msg); exit 0), doc) in (options_register := spec::!options_register); () ;; (* ----------------------------------------- Options ----------------------------------------- *) let properly_append_arg_name_in_help_and_doc ~arg_name_in_help ~doc = let doc = if (String.get doc 0 <> ' ') then (" "^doc) else doc in (arg_name_in_help ^ doc) ;; let register_unit_option (x:string) ?(aliases=[]) ?(doc="undocumented") ?(default=None) ?toggle () = let doc = properly_append_arg_name_in_help_and_doc ~arg_name_in_help:"" ~doc in let result = ref default in let callback = match toggle with | None -> (fun () -> result := Some ()) | Some () -> (fun () -> result := if !result=None then Some () else None) in List.iter (fun x -> let spec = (("-"^x), Arg.Unit callback, doc) in (options_register := spec::!options_register)) (x::aliases); result ;; let register_bool_option (x:string) ?(aliases=[]) ?(arg_name_in_help="BOOL") ?(doc="undocumented") ?(default=None) () = let doc = properly_append_arg_name_in_help_and_doc ~arg_name_in_help ~doc in let result = ref default in List.iter (fun x -> let spec = (("-"^x), Arg.Bool (fun v -> result := Some v), doc) in (options_register := spec::!options_register)) (x::aliases); result ;; (* val compose_tests : (('a -> bool) * error_msg) list -> 'a -> error_msg option *) let rec compose_tests tests = fun v -> match tests with | [] -> None (* it's fine, no errors *) | (test_pred, test_err_msg)::tests -> if test_pred v then compose_tests tests v else (Some test_err_msg) ;; (* val properly_compose_with_tests : ?tests:(('a -> bool) * error_msg) list -> ('a -> 'b) -> ('a -> 'b) *) let properly_compose_with_tests ?tests normal_callback = match tests with | None -> normal_callback | Some tests -> (fun v -> match compose_tests tests v with | None -> normal_callback v | Some err_msg -> raise (Arg.Bad err_msg) ) ;; let convert_int_tests_into_string_tests ?tests () = match tests with | None -> None | Some pms -> Some (List.map (fun (p,m)-> (fun (x:string) -> (p (int_of_string x))),m) pms) ;; let convert_float_tests_into_string_tests ?tests () = match tests with | None -> None | Some pms -> Some(List.map (fun (p,m)-> (fun (x:string) -> (p (float_of_string x))),m) pms) ;; let register_string_option (x:string) ?(aliases=[]) ?tests ?(arg_name_in_help="STRING") ?(doc="undocumented") ?(default=None) () = let result = ref default in let doc = properly_append_arg_name_in_help_and_doc ~arg_name_in_help ~doc in let callback = properly_compose_with_tests ?tests (fun v -> result := Some v) in List.iter (fun x -> let spec = (("-"^x), Arg.String callback, doc) in (options_register := spec::!options_register)) (x::aliases); result ;; (** Could the process perform some operations on the file: read ([?r]) and/or write ([?w]) and/or execution ([?x])? Copied from UnixExtra in order to break the dependence. *) let test_access ?r ?w ?x filename : bool = let xs = [(r,Unix.R_OK); (w,Unix.W_OK); (x,Unix.X_OK)] in let xs = List.filter (fun (v,_)-> v<>None) xs in let xs = Unix.F_OK::(List.map snd xs) in try let _ = Unix.access filename xs in true with Unix.Unix_error (_,_,_) -> false ;; let words_about_access ?r ?w ?x () = let xs = [(r,"readable"); (w,"writable"); (x,"executable")] in let xs = List.filter (fun (v,_)-> v<>None) xs in String.concat " and " (List.map snd xs) ;; let test_kind ?follow ?f ?d ?c ?b ?h ?p ?socket filename = let xs = [(f, Unix.S_REG); (d, Unix.S_DIR); (c, Unix.S_CHR); (b, Unix.S_BLK); (h, Unix.S_LNK); (p, Unix.S_FIFO); (socket, Unix.S_SOCK) ] in let xs = List.filter (fun (v,_)-> v<>None) xs in let xs = (List.map snd xs) in match xs with | [] -> true | [expected_file_kind] -> (try let infos = (if follow=None then Unix.stat else Unix.lstat) filename in infos.Unix.st_kind = expected_file_kind with Unix.Unix_error (_,_,_) -> false) | _ -> false (* No condition was given *) ;; let words_about_kind ?follow ?f ?d ?c ?b ?h ?p ?socket () = let xs = [(h, "symlink"); (f, "regular"); (d, "directory"); (c, "character device"); (b, "block device"); (p, "named pipe"); (socket, "socket") ] in let xs = List.filter (fun (v,_)-> v<>None) xs in (assert ((List.length xs) <= 2)); (* If there are two elements, the first is "symlink" (because of the option ?follow) *) String.concat " -> " (List.map snd xs) ;; let parenthesis_about_access_and_kind ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket () = let r1 = words_about_access ?r ?w ?x () in let r2 = words_about_kind ?follow ?f ?d ?c ?b ?h ?p ?socket () in let r = String.concat " " (List.filter ((<>)"") [r1; r2]) in if r="" then r else (Printf.sprintf "(%s) " r) let test_access_and_kind ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket filename = (test_access ?r ?w ?x filename) && (test_kind ?follow ?f ?d ?c ?b ?h ?p ?socket filename) ;; let register_filename_option (y:string) ?aliases ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests ?(arg_name_in_help="FILE") ?doc ?default () = let file_test = let pred = (test_access_and_kind ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket) in let err_msg = match error_msg with | Some m -> m | None -> let parenthesis = parenthesis_about_access_and_kind ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket () in Printf.sprintf "file doesn't exist or does not fit the conditions; option `-%s' expects a %sfile name." y parenthesis in (pred, err_msg) in (* File related test will be applied foremost: *) let tests = file_test::(match tests with None -> [] | Some ts -> ts) in register_string_option y ?aliases ~arg_name_in_help ~tests ?doc ?default () ;; let register_directory_option (y:string) ?aliases ?r ?w ?x ?error_msg ?tests ?(arg_name_in_help="DIR") ?doc ?default () = let file_test = (* In order to prevent the exception that Sys.is_directory could raise: *) let pred v = (Sys.file_exists v) && (Sys.is_directory v) && (test_access ?r ?w ?x v) in let err_msg = match error_msg with | Some m -> m | None -> let parenthesis = parenthesis_about_access_and_kind ?r ?w ?x () in Printf.sprintf "directory doesn't exist or does not fit the conditions; option `-%s' expects a %sdirectory." y parenthesis in (pred, err_msg) in (* File related test will be applied foremost: *) let tests = file_test::(match tests with None -> [] | Some ts -> ts) in register_string_option y ?aliases ~arg_name_in_help ~tests ?doc ?default () ;; let register_enum_option (x:string) ?(aliases=[]) ~admissible_args ?(doc="undocumented") ?(default=None) () = let result = ref default in let doc = properly_append_arg_name_in_help_and_doc ~arg_name_in_help:"" ~doc in List.iter (fun x -> let spec = (("-"^x), Arg.Symbol (admissible_args, fun v -> result := Some v), doc) in (options_register := spec::!options_register)) (x::aliases); result ;; let register_int_option (x:string) ?(aliases=[]) ?tests ?(arg_name_in_help="INT") ?(doc="undocumented") ?(default=None) () = let result = ref default in let doc = properly_append_arg_name_in_help_and_doc ~arg_name_in_help ~doc in let callback = properly_compose_with_tests ?tests (fun v -> result := Some v) in List.iter (fun x -> let spec = (("-"^x), Arg.Int callback, doc) in (options_register := spec::!options_register)) (x::aliases); result ;; let register_float_option (x:string) ?(aliases=[]) ?tests ?(arg_name_in_help="FLOAT") ?(doc="undocumented") ?(default=None) () = let result = ref default in let doc = properly_append_arg_name_in_help_and_doc ~arg_name_in_help ~doc in let callback = properly_compose_with_tests ?tests (fun v -> result := Some v) in List.iter (fun x -> let spec = (("-"^x), Arg.Float callback, doc) in (options_register := spec::!options_register)) (x::aliases); result ;; (* ----------------------------------------- String arguments ----------------------------------------- *) let register_string_optional_argument ?tests ?(default=None) () = let result = ref default in let callback = properly_compose_with_tests ?tests (fun v -> result := Some v) in let spec = Optional callback in (arguments_register := spec::!arguments_register); result ;; let register_string_argument ?tests ?(error_msg="argument expected") () = let result = ref "" in let callback = properly_compose_with_tests ?tests (fun v -> result := v) in let spec = Mandatory (callback, error_msg) in (arguments_register := spec::!arguments_register); result ;; let register_string_list0_argument ?tests () = let result = ref [] in let callback = properly_compose_with_tests ?tests (fun v -> result := v::!result) in (arguments_register := (List0 callback)::!arguments_register); result ;; let register_string_list1_argument ?tests ?(error_msg="argument(s) expected") () = let result = ref [] in let callback = properly_compose_with_tests ?tests (fun v -> result := v::!result) in (arguments_register := (List1 (callback, error_msg))::!arguments_register); result ;; (* ----------------------------------------- Int arguments ----------------------------------------- *) let register_int_optional_argument ?tests ?(default=None) () = let result = ref default in let tests = convert_int_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := Some (int_of_string v)) in let spec = Optional callback in (arguments_register := spec::!arguments_register); result ;; let register_int_argument ?tests ?(error_msg="int argument expected") () = let result = ref 42 in let tests = convert_int_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := (int_of_string v)) in let spec = Mandatory (callback, error_msg) in (arguments_register := spec::!arguments_register); result ;; let register_int_list0_argument ?tests () = let result = ref [] in let tests = convert_int_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := (int_of_string v)::!result) in (arguments_register := (List0 callback)::!arguments_register); result ;; let register_int_list1_argument ?tests ?(error_msg="int argument(s) expected") () = let result = ref [] in let tests = convert_int_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := (int_of_string v)::!result) in (arguments_register := (List1 (callback, error_msg))::!arguments_register); result ;; (* ----------------------------------------- Float arguments ----------------------------------------- *) let register_float_optional_argument ?tests ?(default=None) () = let result = ref default in let tests = convert_float_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := Some (float_of_string v)) in let spec = Optional callback in (arguments_register := spec::!arguments_register); result ;; let register_float_argument ?tests ?(error_msg="float argument expected") () = let result = ref 42. in let tests = convert_float_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := (float_of_string v)) in let spec = Mandatory (callback, error_msg) in (arguments_register := spec::!arguments_register); result ;; let register_float_list0_argument ?tests () = let result = ref [] in let tests = convert_float_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := (float_of_string v)::!result) in (arguments_register := (List0 callback)::!arguments_register); result ;; let register_float_list1_argument ?tests ?(error_msg="float argument(s) expected") () = let result = ref [] in let tests = convert_float_tests_into_string_tests ?tests () in let callback = properly_compose_with_tests ?tests (fun v -> result := (float_of_string v)::!result) in (arguments_register := (List1 (callback, error_msg))::!arguments_register); result ;; (* ----------------------------------------- Bool arguments ----------------------------------------- *) IFNDEF OCAML4_04_OR_LATER THEN let lowercase = String.lowercase ELSE let lowercase = String.lowercase_ascii ENDIF let register_bool_optional_argument ?(default=None) () = let result = ref default in let spec = Optional (fun v -> result := Some (bool_of_string (lowercase v))) in (arguments_register := spec::!arguments_register); result ;; let register_bool_argument ?(error_msg="bool argument expected") () = let result = ref true in let spec = Mandatory ((fun v -> result := (bool_of_string v)), error_msg) in (arguments_register := spec::!arguments_register); result ;; let register_bool_list0_argument () = let result = ref [] in let callback = (fun v -> result := (bool_of_string (lowercase v))::!result) in (arguments_register := (List0 callback)::!arguments_register); result ;; let register_bool_list1_argument ?(error_msg="bool argument(s) expected") () = let result = ref [] in let callback = (fun v -> result := (bool_of_string v)::!result) in (arguments_register := (List1 (callback, error_msg))::!arguments_register); result ;; (* ----------------------------------------- File arguments ----------------------------------------- *) let make_filename_test_for_argument ?(what="file") ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg () = let pred = (test_access_and_kind ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket) in let err_msg = match error_msg with | Some m -> m | None -> let parenthesis = parenthesis_about_access_and_kind ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket () in Printf.sprintf "the expected %s%s doesn't exist or does not fit the conditions" parenthesis what in (pred, err_msg) (* File related test will be applied foremost: *) let make_filename_tests ?what ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () = let file_test = make_filename_test_for_argument ?what ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg () in file_test::(match tests with None -> [] | Some ts -> ts) let register_filename_optional_argument ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests ?default () = let tests = make_filename_tests ~what:"file" ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () in register_string_optional_argument ~tests ?default () ;; let register_filename_argument ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () = let tests = make_filename_tests ~what:"file" ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () in register_string_argument ~tests ~error_msg:"filename expected" () ;; let register_filename_list0_argument ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () = let tests = make_filename_tests ~what:"file" ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () in register_string_list0_argument ~tests () ;; let register_filename_list1_argument ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () = let tests = make_filename_tests ~what:"file" ?r ?w ?x ?follow ?f ?d ?c ?b ?h ?p ?socket ?error_msg ?tests () in register_string_list1_argument ~tests ~error_msg:"filename(s) expected" () ;; (* ----------------------------------------- Parsing actuals ----------------------------------------- *) type attempt = Success of unit | Failure of error_msg let attempt_and_branch ?(err_msg="attempt_and_branch") f a ~success ~failure = let attempt = try Success (f a) with | Arg.Bad err_msg -> Failure err_msg | _ -> Failure err_msg (* in this case failure does not really need an argument *) in (* Note that it's relevant that the continuations (success and failure) are called out of the try-with bloc: *) match attempt with | Success () -> success () | Failure err_msg -> failure err_msg ;; let parse_actuals ~usage_with_options ~arguments_spec_list ~actuals = let raise_bad nth err_msg = let usage_with_options = if !Tuning.no_usage_on_error_parsing_arguments<>None then "" else Lazy.force usage_with_options in let bad_err_msg = match !Tuning.no_error_location_parsing_arguments with | None -> Printf.sprintf "%s: argument #%d: %s\n%s" Sys.argv.(0) nth err_msg usage_with_options | Some () -> Printf.sprintf "%s\n%s" err_msg usage_with_options in (raise (Arg.Bad bad_err_msg)) in let rec loop nth sl al = match sl,al with | (Optional f)::sl', a::al' -> attempt_and_branch f a ~success:(fun () -> loop (nth+1) sl' al') ~failure:(fun _ -> loop nth sl' al) | (Optional f)::sl', [] -> loop nth sl' [] | (Optional_last f)::sl', a::al' -> attempt_and_branch f a ~success:(fun () -> loop (nth+1) sl' al') ~failure:(raise_bad nth) | (Optional_last f)::sl', [] -> loop nth sl' [] | (Mandatory (f, _))::sl', a::al' -> (* In case of failure, the error_msg is provided by the raised exception: *) attempt_and_branch f a ~success:(fun () -> loop (nth+1) sl' al') ~failure:(raise_bad nth) | (Mandatory (f, err_msg))::sl', [] -> (raise_bad nth err_msg) | (List0 f)::sl', a::al' -> attempt_and_branch f a ~success:(fun () ->loop (nth+1) sl al') ~failure:(fun _ -> loop nth sl' al) | (List0 f)::sl', [] -> loop nth sl' [] | (List1 (f, _))::sl', a::al' -> (* In case of failure, the error_msg is provided by the raised exception: *) attempt_and_branch f a ~success:(fun () -> loop (nth+1) ((List0 f)::sl') al') ~failure:(raise_bad nth) | (List1 (f, err_msg))::sl', [] -> (raise_bad nth err_msg) | (List0_last f)::sl', a::al' -> (* In case of failure, the error_msg is provided by the raised exception: *) attempt_and_branch f a ~success:(fun () -> loop (nth+1) sl al') ~failure:(raise_bad nth) | (List0_last f)::sl', [] -> loop nth sl' [] | (List1_last (f, _))::sl', a::al' -> (* In case of failure, the error_msg is provided by the raised exception: *) attempt_and_branch f a ~success:(fun () -> loop (nth+1) ((List0_last f)::sl') al') ~failure:(raise_bad nth) | (List1_last (f, err_msg))::sl', [] -> (raise_bad nth err_msg) | [], a::al' -> let err_msg = Printf.sprintf "unexpected argument `%s'" a in (raise_bad nth err_msg) | [], [] -> () in loop 1 arguments_spec_list actuals (* ----------------------------------------- Parsing command line ----------------------------------------- *) let get_options_spec_list () = Arg.align (List.rev !options_register) let get_arguments_spec_list () = (* Tagging the last list allows us to offer a more comprehensible error message to the user. Indeed, instead of having error messages in the form "unexpected argument", we will have the error message raised by the last executed test (associated to the last list). *) let xs = match !arguments_register with | (Optional f)::xs -> (Optional_last f)::xs | (List0 f)::xs -> (List0_last f)::xs | (List1 (f,err_msg))::xs -> (List1_last (f,err_msg))::xs | xs -> xs in List.rev xs let parse_argv argv = let options_spec_list = get_options_spec_list () in let actuals = ref [] in let anon_fun_collecting_actuals = fun (x:string) -> (actuals := x::!actuals) in (* Parse the actual options: *) let () = Arg.parse_argv argv options_spec_list anon_fun_collecting_actuals !usage_msg in (* Parse now the actual arguments: *) let () = parse_actuals ~usage_with_options:(lazy (Arg.usage_string options_spec_list !usage_msg)) ~arguments_spec_list:(get_arguments_spec_list ()) ~actuals:(List.rev !actuals) in () ;; let parse ?(exit_with_errno=1) () = try let options_spec_list = get_options_spec_list () in let actuals = ref [] in let anon_fun_collecting_actuals = fun (x:string) -> (actuals := x::!actuals) in (* Parse the actual options: *) let () = Arg.parse options_spec_list anon_fun_collecting_actuals !usage_msg in (* Parse now the actual arguments: *) let () = parse_actuals ~usage_with_options:(lazy (Arg.usage_string options_spec_list !usage_msg)) ~arguments_spec_list:(get_arguments_spec_list ()) ~actuals:(List.rev !actuals) in () with Arg.Bad msg -> begin Printf.fprintf stderr "%s" msg; exit exit_with_errno; end ;; ocamlbricks-0.90+bzr456.orig/BASE/fix.mli0000644000175000017500000000205713175721005016732 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007-2009 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Poor man fix point operators. *) val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b val efix : ('a -> ('a -> 'b -> 'c) -> 'b -> 'c) -> 'a -> 'b -> 'c val ecfix : ('a -> 'b -> 'c) -> ('d -> ('d -> 'b -> 'c) -> 'a) -> 'd -> 'b -> 'c val find : ?equals:('a -> 'a -> bool) -> ?loops_limit:int -> ('a -> 'a) -> 'a -> 'a ocamlbricks-0.90+bzr456.orig/BASE/ocamlbricks_log.ml0000644000175000017500000000303113175721005021116 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2011 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** A [Log_builder.Make] instance ready-to-use in the application loading this module. The [debug_level] is initially set to [0], the [verbosity] is set to [1], the [log_channel] is set to [`stderr] and [synchronized] is set to [true]. *) (* Initialized later, by Global_options, in order to break the ciclic dependency: *) include Log_builder.Make (struct let debug_level () = 0 (* the debug_level must be greater or equal to the verbosity, otherwise do nothing *) let verbosity = 1 (* the default value of verbosity for printing functions *) let log_channel = `stderr (* put messages here *) let synchronized = true (* using threads *) end);; let enable () = Tuning.Set.debug_level (fun () -> 1) let disable () = Tuning.Set.debug_level (fun () -> 0) ocamlbricks-0.90+bzr456.orig/SHELL/0000755000175000017500000000000013175721005015572 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/SHELL/shell.ml0000644000175000017500000003314513175721005017241 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo Updated in 2008 by Jean-Vincent Loddo and Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** A collection of simple wrappers for the most famous {e Unix} tools ({b grep}, {b dd}, {b tar},..). *) open Sugar;; module Treat = Wrapper.Treat (** A {e filename} is a string. *) type filename = string;; (** A {e filexpr} is a string (with meta-characters, for instance ["/etc/*tab"]). *) type filexpr = string;; (** A {e foldername} is a string. *) type foldername = string;; type line = string type text = line list (** {2 Text filters} *) (** Wrapper for the {b awk} unix filter. The first argument is the awk program, the second one is the input text (string list). {b Example}: {[# awk "{print $1}" ["Hello World";"Bye Bye"];; : string list = ["Hello"; "Bye"] ]}*) let awk ?(opt="") prog text = Wrapper.textfilter ~at:Treat.quote "awk" ~opt ~args:(Some(prog)) text ;; (** Wrapper for the {b cut} unix filter. {b Example}: {[# cut "-d: -f2,3" ["AA:BB:CC:DD:EE:FF"];; : string list = ["BB:CC"] ]}*) let cut args text = Wrapper.textfilter ~at:Treat.identity "cut" ~args:(Some(args)) text ;; (** Wrapper for the {b head} unix filter. {b Examples}: {[# head ["hello world"; "bye bye"];; : string list = ["hello world"; "bye bye"] # head ~opt:"-1" ["hello world"; "bye bye"];; : string list = ["hello world"]]}*) let head ?(opt="") text = Wrapper.textfilter "head" ~opt text ;; (** Wrapper for the {b grep} unix filter. {b Examples}: {[# grep "aa" ["aaa";"bbb";"caa";"ddd"];; : string list = ["aaa"; "caa"] # grep ~opt:"-v" "aa" ["aaa";"bbb";"caa";"ddd"];; : string list = ["bbb"; "ddd"] ]}*) let grep ?(opt="") regexp text = Wrapper.textfilter ~at:Treat.quote "grep" ~opt ~args:(Some(regexp)) text ;; (** Wrapper for the {b nl} unix filter. {b Examples}: {[# nl ["first"; "second";"third"];; : string list = [" 1\tfirst"; " 2\tsecond"; " 3\tthird"] # nl ~opt:"-w 1" ["first"; "second";"third"];; : string list = ["1\tfirst"; "2\tsecond"; "3\tthird"] ]}*) let nl ?(opt="") text = Wrapper.textfilter "nl" ~opt text ;; (** Wrapper for the {b sed} unix filter. By default [~opt="-e"]. {b Example}: {[# sed "s/e/E/g" ["Hello World";"Bye Bye"];; : string list = ["HEllo World"; "ByE ByE"] ]}*) let sed ?(opt="-e") prog text = Wrapper.textfilter ~at:Treat.quote "sed" ~opt ~args:(Some(prog)) text ;; (** Wrapper for the {b sort} unix filter. {b Examples}: {[# sort ["Hello";"Salut"; "Ciao" ];; : string list = ["Ciao"; "Hello"; "Salut"] # sort ~opt:"-r" ["Hello";"Salut"; "Ciao" ];; : string list = ["Salut"; "Hello"; "Ciao"] ]}*) let sort ?(opt="") text = Wrapper.textfilter "sort" ~opt text ;; (** Wrapper for the {b tac} unix filter. {b Example}: {[# tac ["Hello";"Salut"; "Ciao" ];; : string list = ["Ciao"; "Salut"; "Hello"] ]}*) let tac ?(opt="") text = Wrapper.textfilter "tac" ~opt text ;; (** Wrapper for the {b tail} unix filter. {b Examples}: {[# tail ["Hello";"Salut"; "Ciao" ];; : string list = ["Hello"; "Salut"; "Ciao"] # tail ~opt:"-2" ["Hello";"Salut"; "Ciao" ];; : string list = ["Salut"; "Ciao"] ]}*) let tail ?(opt="") text = Wrapper.textfilter "tail" ~opt text ;; (** Wrapper for the {b tee} unix filter. Filenames are quoted then merged with the blank separator. {b Example}: {[# tee ["foo.bar"] ["Salut"; "Hello"; "Ciao"];; : string list = ["Salut"; "Hello"; "Ciao"] # Unix.cat "foo.bar";; : string = "Salut\nHello\nCiao\n"] ]}*) let tee ?(opt="") (files:filename list) text = let args = List.map StringExtra.quote files in let args = String.concat " " args in Wrapper.textfilter ~at:Treat.identity "tee" ~opt ~args:(Some args) text ;; (** Wrapper for the {b tr} unix filter. {b Example}: {[# tr 'a' 'A' ["Salut"; "Hello"; "Ciao"];; : string list = ["SAlut"; "Hello"; "CiAo"] ]}*) let tr ?(opt="") c1 c2 text = let s1 = StringExtra.quote (Char.escaped c1) in let s2 = StringExtra.quote (Char.escaped c2) in let args = String.concat " " [s1;s2] in Wrapper.textfilter ~at:Treat.identity "tr" ~opt ~args:(Some args) text ;; (** Wrapper for the {b uniq} unix filter. {b Example}: {[# uniq ["AA"; "BB"; "CC"; "CC"; "AA"];; : string list = ["AA"; "BB"; "CC"; "AA"] ]}*) let uniq ?(opt="") text = Wrapper.textfilter "uniq" ~opt text ;; (** {2 Text summary} *) (** Wrapper for the {b wc -w} unix word counter. {b Example}: {[# wc ["AA BB"; "CC"; "DD EE"];; : int = 5 ]}*) let wc text : int = Wrapper.make ~it:(Some StringExtra.Text.to_string) ~ot:(StringExtra.chop || int_of_string) "wc -w" ~input:(Some text) () ;; (** Wrapper for the {b wc -c} unix char counter. In a {e strict} sense, the newline characters added to strings in order to trasform them in lines (if needed) are not counted. By default [strict=false]. {b Examples}: {[# cc ["AA BB"; "CC"];; : int = 9 # cc ["AA BB\n"; "CC\n"];; : int = 9 # cc ~strict:true ["AA BB"; "CC"];; : int = 7 ]}*) let cc ?(strict=false) text : int = let it = Some(if strict then (String.concat "") else (StringExtra.Text.to_string)) in Wrapper.make ~it ~ot:(StringExtra.chop || int_of_string) "wc -c" ~input:(Some text) () ;; (** {2 Filtering files} *) (** Wrappers operating on filexpr and providing as result a text (string list). *) module Files = struct (** Expand a file expression (with meta-characters) into the list of existing files. The optional parameter [null] refers to the [nullglob] bash option. By default [null=false]. {[# Files.glob "/etc/*tab";; : string list = ["/etc/crontab"; "/etc/fstab"; "/etc/inittab"; "/etc/mtab"] ]}*) let glob ?(null=false) (args:filexpr) = let shopt = ("shopt "^(if null then "-s" else "-u")^" nullglob\n") in let cmd = shopt^"for i in \"$@\"; do echo $i; done" in Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string cmd ~script:true ~args:(Some args) ();; (** The following functions are wrappers of the homonymous unix command. The difference from the [Shell] versions is that they ignore their input and take a [filexpr] as unique argument. *) (** Wrapper for the {b cat} unix filter. {b Examples}: {[# wc (Files.cat "/etc/*tab");; : int = 1418 # wc (Files.cat ~opt:"-n" "/etc/*tab");; : int = 1691]}*) let cat ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "cat" ~opt ~args:(Some arg) ();; let cut ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "cut" ~opt ~args:(Some arg) ();; let head ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "head" ~opt ~args:(Some arg) ();; let file ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "file" ~opt ~args:(Some arg) ();; let nl ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "nl" ~opt ~args:(Some arg) ();; let sort ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "sort" ~opt ~args:(Some arg) ();; let tac ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "tac" ~opt ~args:(Some arg) ();; let tail ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "tail" ~opt ~args:(Some arg) ();; let uniq ?(opt="") (arg:filexpr) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "uniq" ~opt ~args:(Some arg) ();; end;; (** {2 System info} *) (** Wrapper for the {b date} unix command. {b Examples}: {[# date ();; : string = "mar avr 17 21:06:30 CEST 2007" # date ~arg:"+%d-%m-%Y.%kh%M" ();; : string = "17-04-2007.21h06" ]}*) let date ?(opt="") ?(arg="") () = Wrapper.make ~at:Treat.identity ~ot:StringExtra.chop "date" ~opt ~args:(Some arg) ();; (** Wrapper for the {b id} unix command. {b Examples}: {[# id ();; : string = "uid=3013(loddo) gid=1031(lcr) groupes=0(root),1031(lcr)" # id ~opt:"-g" ();; : string = "1031" ]}*) let id ?(opt="") ?(arg="") () = Wrapper.make ~at:Treat.identity ~ot:StringExtra.chop "id" ~opt ~args:(Some arg) ();; (** Wrapper for the {b uname} unix command. {b Examples}: {[# uname ();; : string = "Linux" # uname ~opt:"-r" ();; : string = "2.6.16.27-0.6-smp" ]}*) let uname ?(opt="") () = Wrapper.make ~ot:StringExtra.chop "uname" ~opt ();; (** Wrapper for the {b whoami} unix command. {b Example}: {[# whoami ();; : string = "loddo" ]}*) let whoami () = Wrapper.make ~ot:StringExtra.chop "whoami" ();; (** {2 Stuff} *) (** {3 find} *) (** Wrapper for find. {b Example}: {[# find "/etc/*tab -name '*n*'";; : string list = ["/etc/crontab"; "/etc/inittab"] ]}*) let find (arg:string) = Wrapper.make ~at:Treat.identity ~ot:StringExtra.Text.of_string "find" ~args:(Some arg) ();; (** {3 dd} *) (** A quite sofisticated wrapper for dd. The input (first argument) and output (second argument) filenames are automatically quoted. {b Examples:} {[# dd "/etc/fstab" "fstab.copy";; 2+1 records in 2+1 records out 1130 bytes (1,1 kB) copied, 0,00017 seconde, 6,6 MB/s : unit = () # dd ~ibs:(Some 256) ~obs:(Some 256) "/etc/fstab" "fstab.copy";; 4+1 records in 4+1 records out 1130 bytes (1,1 kB) copied, 0,000191 seconde, 5,9 MB/s : unit = () ]}*) let dd ?(ibs=None) ?(obs=None) ?(bs=None) ?(cbs=None) ?(skip=None) ?(seek=None) ?(count=None) ?(conv=None) (x:filename) (y:filename) = let iF = " if="^(StringExtra.quote x) in let oF = " of="^(StringExtra.quote y) in let ibs = match ibs with (Some n) -> " ibs=" ^ (string_of_int n) | _ -> "" in let obs = match obs with (Some n) -> " obs=" ^ (string_of_int n) | _ -> "" in let bs = match bs with (Some n) -> " bs=" ^ (string_of_int n) | _ -> "" in let cbs = match cbs with (Some n) -> " cbs=" ^ (string_of_int n) | _ -> "" in let skip = match skip with (Some n) -> " skip=" ^ (string_of_int n) | _ -> "" in let seek = match seek with (Some n) -> " seek=" ^ (string_of_int n) | _ -> "" in let count= match count with (Some n) -> " count="^ (string_of_int n) | _ -> "" in let conv = match conv with (Some n) -> " conv=" ^ (string_of_int n) | _ -> "" in let arg = (iF^oF^ibs^obs^bs^cbs^skip^seek^count^conv) in Wrapper.make ~at:Treat.identity ~ot:ignore "dd" ~args:(Some arg) () ;; (** {3 tar} *) (** Wrapper for the command [tar -cz]. {b Example:} {[# tgz_create "mysite.tgz" "/var/www/html /etc/httpd*";; : unit = () ]}*) let tgz_create ?(opt="") (fname:filename) (files:filexpr) = let at (t,e) = ((StringExtra.quote t)^" "^e) in Wrapper.make ~at:(Some at) ~ot:ignore ("tar "^opt^" -czf $@") ~script:true ~args:(Some (fname,files)) () ;; (** Wrapper for the command [tar -xz]. The gzip compressed archive will be extracted in the specified folder. {b Example:} {[# tgz_extract "foo.tgz" "temp/";; : unit = () ]}*) let tgz_extract ?(opt="") (fname:filename) (rep:foldername) = let at (t,r) = ((StringExtra.quote t)^" "^(StringExtra.quote r)) in Wrapper.make ~at:(Some at) ~ot:ignore ("tar "^opt^" -C $2 -xzf $1") ~script:true ~args:(Some (fname,rep)) () ;; type pid = int let get_children_by_the_external_command_ps ?(pid=Unix.getpid ()) () = let command = Printf.sprintf "ps --ppid %d -o pid --no-headers" pid in let result = List.map (fun x -> int_of_string (StringExtra.strip x)) (StringExtra.Text.of_string (UnixExtra.shell (command))) in (* this filter may remove the `ps' process used before which is dead now: *) List.filter (UnixExtra.is_process_alive) result ;; let get_children_by_ps = get_children_by_the_external_command_ps ;; let rec get_descendants_by_ps ?(pid=Unix.getpid ()) () = let children = get_children_by_ps ~pid () in List.concat (List.map (fun pid -> pid::(get_descendants_by_ps ~pid ())) children) ;; let rec kill_children_by_ps ?(pid=Unix.getpid ()) () = let get_children () = get_children_by_ps ~pid () in (* --- Step 1: send SIGTERM (15) to children: *) let children = get_children () in if children = [] then () (* return *) else (* continue *) let () = List.iter (fun pid -> try Unix.kill pid 15 with _ -> ()) (List.rev children) in (* --- Step 2: send SIGINT (2) to remaining children: *) let children = get_children () in if children = [] then () (* return *) else (* continue *) let () = List.iter (fun pid -> try Unix.kill pid 2 with _ -> ()) (List.rev children) in (* --- Step 3: send SIGKILL (9) to remaining children: *) let children = get_children () in if children = [] then () (* return *) else (* continue *) let () = List.iter (fun pid -> try Unix.kill pid 9 with _ -> ()) (List.rev children) in () ;; let rec kill_descendants_by_ps ?(pid=Unix.getpid ()) () = (* --- Step 1: recursively kill children's descendance: *) let children = get_children_by_ps ~pid () in if children = [] then () (* return *) else (* continue *) let () = List.iter (fun pid -> kill_descendants_by_ps ~pid ()) (List.rev children) in (* --- Step 2: kill now the children: *) kill_children_by_ps ~pid () ;; (** Escape blanks, parenthesis, '&', '*' and '?'. {b Example:} {[# escaped_filename "foo (v0.1)" ;; : string = "foo\\ \\(v0.1\\)" ]}*) let escaped_filename : string -> string = StrExtra.Global.substitute (Str.regexp "[ )(&*?]") (Printf.sprintf "\\%s") ;; ocamlbricks-0.90+bzr456.orig/SHELL/shell.mli0000644000175000017500000000406113175721005017405 0ustar lucaslucastype filename = string type filexpr = string type foldername = string type line = string type text = line list val awk : ?opt:string -> string -> text -> text val cut : string -> text -> text val head : ?opt:string -> text -> text val grep : ?opt:string -> string -> text -> text val nl : ?opt:string -> text -> text val sed : ?opt:string -> string -> text -> text val sort : ?opt:string -> text -> text val tac : ?opt:string -> text -> text val tail : ?opt:string -> text -> text val tee : ?opt:string -> filename list -> text -> text val tr : ?opt:string -> char -> char -> text -> text val uniq : ?opt:string -> text -> text val wc : text -> int val cc : ?strict:bool -> text -> int module Files : sig val glob : ?null:bool -> filexpr -> text val cat : ?opt:string -> filexpr -> text val file : ?opt:string -> filexpr -> text val cut : ?opt:string -> filexpr -> text val head : ?opt:string -> filexpr -> text val nl : ?opt:string -> filexpr -> text val sort : ?opt:string -> filexpr -> text val tac : ?opt:string -> filexpr -> text val tail : ?opt:string -> filexpr -> text val uniq : ?opt:string -> filexpr -> text end val date : ?opt:string -> ?arg:string -> unit -> string val id : ?opt:string -> ?arg:string -> unit -> string val uname : ?opt:string -> unit -> string val whoami : unit -> string val find : string -> text val dd : ?ibs:int option -> ?obs:int option -> ?bs:int option -> ?cbs:int option -> ?skip:int option -> ?seek:int option -> ?count:int option -> ?conv:int option -> filename -> filename -> unit val tgz_create : ?opt:string -> filename -> filexpr -> unit val tgz_extract : ?opt:string -> filename -> foldername -> unit (** Get or kill children or descendants using the command [ps(1)] : *) type pid = int val get_children_by_ps : ?pid:int -> unit -> pid list val get_descendants_by_ps : ?pid:int -> unit -> pid list val kill_children_by_ps : ?pid:int -> unit -> unit val kill_descendants_by_ps : ?pid:int -> unit -> unit val escaped_filename : filename -> filename ocamlbricks-0.90+bzr456.orig/SHELL/wrapper.mli0000644000175000017500000000326713175721005017765 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Handling shell scripts in {e OCaml}. A general technique for wrapping shell commands or scripts is proposed in this module. The technique is applied in the module {!Shell} for building a significative set of ready-to-use wrappers corresponding to the most famous {e Unix} tools ({b grep}, {b dd}, {b tar},..). *) type command = string type content = string type arg = string type call = string type script = string val envelop : ?name:string -> script -> call val make : ?at:('a -> string) option -> ?it:('b -> string) option -> ot:(string -> 'c) -> ?script:bool -> command -> ?opt:string -> ?args:'a option -> ?input:'b option -> unit -> 'c val textfilter : ?at:('a -> string) option -> ?script:bool -> command -> ?opt:string -> ?args:'a option -> StringExtra.Text.t -> StringExtra.Text.t module Treat : sig val identity : ('a -> 'a) option val quote : (string -> string) option val is_true : string -> bool end ocamlbricks-0.90+bzr456.orig/SHELL/linux.mli0000644000175000017500000003646613175721005017453 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo Copyright (C) 2013 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Specific functions for [Linux]. *) type pid = int (** The number of processors, read from /proc/cpuinfo: *) val processor_no : int lazy_t (** [Linux] processes related features. With respect to the other [Unix], we suppose here to be able to get information from [/proc//] directories.*) module Process : sig (** Simplified (and object-oriented) version of the main type [stat] full commented later: *) type easy_stat = < pid:int; comm:string; state:char; ppid:int; pgrp:int; session:int; tty_nr:int; tpgid:int; other_fields:string > (** Source: [http://man7.org/linux/man-pages/man5/proc.5.html]. Status information about the process provided by [/proc//stat]. This is used by [ps(1)]. It is defined in [/usr/src/linux/fs/proc/array.c]. The fields are listed with their proper [scanf(3)] format specifiers. *) type stat = { pid : int; (** %d (1) The process ID. *) comm : string; (** %s (2) The filename of the executable, in parentheses. This is visible whether or not the executable is swapped out. *) state : char; (** %c (3) One character from the string "RSDZTW" where R is running, S is sleeping in an interruptible wait, D is waiting in uninterruptible disk sleep, Z is zombie, T is traced or stopped (on a signal), and W is paging. *) ppid : int; (** %d (4) The PID of the parent. *) pgrp : int; (** %d (5) The process group ID of the process. *) session : int; (** %d (6) The session ID of the process. *) tty_nr : int; (** %d (7) The controlling terminal of the process. (The minor device number is contained in the combination of bits 31 to 20 and 7 to 0; the major device number is in bits 15 to 8.) *) tpgid : int; (** %d (8) The ID of the foreground process group of the controlling terminal of the process. *) flags : int64; (** %lu (should be %u, or %lu before Linux 2.6.22) (9) The kernel flags word of the process. For bit meanings, see the PF_* defines in the Linux kernel source file include/linux/sched.h. Details depend on the kernel version. *) minflt : int64; (** %lu (10) The number of minor faults the process has made which have not required loading a memory page from disk. *) cminflt : int64; (** %lu (11) The number of minor faults that the process's waited-for children have made. *) majflt : int64; (** %lu (12) The number of major faults the process has made which have required loading a memory page from disk. *) cmajflt : int64; (** %lu (13) The number of major faults that the process's waited-for children have made. *) utime : int64; (** %lu (14) Amount of time that this process has been scheduled in user mode, measured in clock ticks (divide by sysconf(_SC_CLK_TCK)). This includes guest time, guest_time (time spent running a virtual CPU, see below), so that applications that are not aware of the guest time field do not lose that time from their calculations. *) stime : int64; (** %lu (15) Amount of time that this process has been scheduled in kernel mode, measured in clock ticks (divide by sysconf(_SC_CLK_TCK)). *) cutime : int64; (** %ld (16) Amount of time that this process's waited-for children have been scheduled in user mode, measured in clock ticks (divide by sysconf(_SC_CLK_TCK)). (See also times(2).) This includes guest time, cguest_time (time spent running a virtual CPU, see below). *) cstime : int64; (** %ld (17) Amount of time that this process's waited-for children have been scheduled in kernel mode, measured in clock ticks (divide by sysconf(_SC_CLK_TCK)). *) priority : int64; (** %ld (18) (Explanation for Linux 2.6) For processes running a real-time scheduling policy (policy below; see sched_setscheduler(2)), this is the negated scheduling priority, minus one; that is, a number in the range -2 to -100, corresponding to real-time priorities 1 to 99. For processes running under a non-real-time scheduling policy, this is the raw nice value (setpriority(2)) as represented in the kernel. The kernel stores nice values as numbers in the range 0 (high) to 39 (low), corresponding to the user-visible nice range of -20 to 19. Before Linux 2.6, this was a scaled value based on the scheduler weighting given to this process. *) nice : int64; (** %ld (19) The nice value (see setpriority(2)), a value in the range 19 (low priority) to -20 (high priority). *) num_threads : int64;(** %ld (20) Number of threads in this process (since Linux 2.6). Before kernel 2.6, this field was hard coded to 0 as a placeholder for an earlier removed field. *) itrealvalue : int64;(** %ld (21) The time in jiffies before the next SIGALRM is sent to the process due to an interval timer. Since kernel 2.6.17, this field is no longer maintained, and is hard coded as 0. *) starttime : int64; (** %llu (was %lu before Linux 2.6) (22) The time the process started after system boot. In kernels before Linux 2.6, this value was expressed in jiffies. Since Linux 2.6, the value is expressed in clock ticks (divide by sysconf(_SC_CLK_TCK)). *) vsize : int64; (** %lu (23) Virtual memory size in bytes. *) rss : int64; (** %ld (24) Resident Set Size: number of pages the process has in real memory. This is just the pages which count toward text, data, or stack space. This does not include pages which have not been demand-loaded in, or which are swapped out. *) rsslim : int64 option; (** %lu (25) Current soft limit in bytes on the rss of the process; see the description of RLIMIT_RSS in getrlimit(2). *) startcode : int64; (** %lu (26) The address above which program text can run. *) endcode : int64; (** %lu (27) The address below which program text can run. *) startstack : int64; (** %lu (28) The address of the start (i.e., bottom) of the stack. *) kstkesp : int64; (** %lu (29) The current value of ESP (stack pointer), as found in the kernel stack page for the process. *) kstkeip : int64; (** %lu (30) The current EIP (instruction pointer). *) signal : int64; (** %lu (31) The bitmap of pending signals, displayed as a decimal number. Obsolete, because it does not provide information on real-time signals; use /proc/[pid]/status instead. *) blocked : int64; (** %lu (32) The bitmap of blocked signals, displayed as a decimal number. Obsolete, because it does not provide information on real-time signals; use /proc/[pid]/status instead. *) sigignore : int64; (** %lu (33) The bitmap of ignored signals, displayed as a decimal number. Obsolete, because it does not provide information on real-time signals; use /proc/[pid]/status instead. *) sigcatch : int64; (** %lu (34) The bitmap of caught signals, displayed as a decimal number. Obsolete, because it does not provide information on real-time signals; use /proc/[pid]/status instead. *) wchan : int64 option;(** %lu (35) This is the "channel" in which the process is waiting. It is the address of a system call, and can be looked up in a namelist if you need a textual name. (If you have an up-to-date /etc/psdatabase, then try ps -l to see the WCHAN field in action.) *) nswap : int64; (** %lu (36) Number of pages swapped (not maintained). *) cnswap : int64; (** %lu (37) Cumulative nswap for child processes (not maintained). *) exit_signal : int; (** %d (since Linux 2.1.22) (38) Signal to be sent to parent when we die. *) processor : int; (** %d (since Linux 2.2.8) (39) CPU number last executed on. *) rt_priority : int64;(** %lu (should be %u since Linux 2.5.19; was %lu before Linux 2.6.22) (40) Real-time scheduling priority, a number in the range 1 to 99 for processes scheduled under a real-time policy, or 0, for non-real-time processes (see sched_setscheduler(2)). *) policy : int64; (** %lu (should be %u since Linux 2.5.19; was %lu before Linux 2.6.22) (41) Scheduling policy (see sched_setscheduler(2)). Decode using the SCHED_* constants in linux/sched.h. *) delayacct_blkio_ticks : int64; (** %llu (since Linux 2.6.18) (42) Aggregated block I/O delays, measured in clock ticks (centiseconds). *) guest_time : int64; (** %lu (since Linux 2.6.24) (43) Guest time of the process (time spent running a virtual CPU for a guest operating system), measured in clock ticks (divide by sysconf(_SC_CLK_TCK)). *) cguest_time : int64;(** %ld (since Linux 2.6.24) (44) Guest time of the process's children, measured in clock ticks (divide by sysconf(_SC_CLK_TCK)). *) } (* type stat *) (** Status information about the process. Implemented reading the file [/proc//stat]. *) val stat : pid -> stat option (** Status information about the process (simplified object-oriented data structure). Implemented as [stat] reading the file [/proc//stat]. *) val easy_stat : pid -> easy_stat option (** Get statistics of all currently running processes. *) val get_stats : unit -> stat list (** Get statistics of all currently running processes (using the simplified structure). *) val get_easy_stats : unit -> easy_stat list (** {2 Descendants' PID}*) (** Get the children PID list of the caller (by default) or the provided [~pid]. *) val get_children : ?pid:int -> unit -> pid list (** Get the PID list of the descendants of the caller (by default) or the provided [~pid]. *) val get_descendants : ?pid:int -> unit -> pid list (** Get the PID hierarchy (forest) of the descendants of the caller (by default) or the provided [~pid]. *) val get_descendants_as_forest : ?pid:int -> unit -> pid Forest.t (** {2 Descendants' statistics}*) (** Get the statistics list of the descendants of the caller (by default) or the provided [~pid]. *) val get_descendant_stats : ?pid:int -> unit -> stat list (** Get the statistics list of the descendants of the caller (by default) or the provided [~pid] (using the simplified structure). *) val get_descendant_easy_stats : ?pid:int -> unit -> easy_stat list (** Get the statistics hierarchy (forest) of the descendants of the caller (by default) or the provided [~pid]. *) val get_descendant_stats_as_forest : ?pid:int -> unit -> stat Forest.t (** Get the statistics hierarchy (forest) of the descendants of the caller (by default) or the provided [~pid] (using the simplified structure). *) val get_descendant_easy_stats_as_forest : ?pid:int -> unit -> easy_stat Forest.t (** {2 Kill descendants}*) (** Kill the whole hierarchy (forest) of the descendants of the caller (by default) or the provided [~pid]. By default the children are processed concurrently (and recursively) using futures. The sequence of signals send to each process (from leafs to root) are (by default) the following in this order: [\[Sys.sigterm; Sys.sigint; Sys.sigcont; Sys.sigkill]\]. After each signal in the sequence, we leave to the fathers the time [wait_delay] to register the death of their children. The processes still alive are then recalculated and the next signal is sent to the survivors and so on. Optional parameters and their defaults: {[?sequential:unit (* Process the children sequentially (instead of concurrently) *) ?wait_delay:float (* Default: 0.1 (seconds) *) ?wait_delay_node_increase_factor:float (* Increase factor for each retry at any node level. Default: 2. *) ?wait_delay_root_increase_factor:float (* Increase factor for each retry at root level. Default: 2. *) ?node_max_retries:int (* Default: 1 *) ?root_max_retries:int (* Default: 1 *) ?signal_sequence:int list (* Default: [Sys.sigterm; Sys.sigint; Sys.sigcont; Sys.sigkill] *) ?pid:int (* Default: the pid of the caller *) ]} *) val kill_descendants : ?sequential:unit -> ?wait_delay:float -> ?wait_delay_node_increase_factor:float -> ?wait_delay_root_increase_factor:float -> ?node_max_retries:int -> ?root_max_retries:int -> ?signal_sequence:int list -> ?pid:int -> unit -> unit end (* Process *) ocamlbricks-0.90+bzr456.orig/SHELL/linux.ml0000644000175000017500000003522713175721005017274 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013 Jean-Vincent Loddo Copyright (C) 2013 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following line: it's an ocamldoc workaround!*) (** *) type pid = int module Process = struct type stat = { pid : int; (* %d (1) *) comm : string; (* %s (2) *) state : char; (* %c (3) *) ppid : int; (* %d (4) *) pgrp : int; (* %d (5) *) session : int; (* %d (6) *) tty_nr : int; (* %d (7) *) tpgid : int; (* %d (8) *) flags : int64; (* %lu (should be %u, or %lu before Linux 2.6.22) (9) *) minflt : int64; (* %lu (10) *) cminflt : int64; (* %lu (11) *) majflt : int64; (* %lu (12) *) cmajflt : int64; (* %lu (13) *) utime : int64; (* %lu (14) *) stime : int64; (* %lu (15) *) cutime : int64; (* %ld (16) *) cstime : int64; (* %ld (17) *) priority : int64; (* %ld (18) *) nice : int64; (* %ld (19) *) num_threads : int64; (* %ld (20) *) itrealvalue : int64; (* %ld (21) *) starttime : int64; (* %llu (was %lu before Linux 2.6) (22) *) vsize : int64; (* %lu (23) *) rss : int64; (* %ld (24) *) rsslim : int64 option; (* %lu (25) *) startcode : int64; (* %lu (26) *) endcode : int64; (* %lu (27) *) startstack : int64; (* %lu (28) *) kstkesp : int64; (* %lu (29) *) kstkeip : int64; (* %lu (30) *) signal : int64; (* %lu (31) *) blocked : int64; (* %lu (32) *) sigignore : int64; (* %lu (33) *) sigcatch : int64; (* %lu (34) *) wchan : int64 option; (* %lu (35) *) nswap : int64; (* %lu (36) *) cnswap : int64; (* %lu (37) *) exit_signal : int; (* %d (since Linux 2.1.22) (38) *) processor : int; (* %d (since Linux 2.2.8) (39) *) rt_priority : int64; (* %lu (should be %u since Linux 2.5.19; was %lu before Linux 2.6.22) (40) *) policy : int64; (* %lu (should be %u since Linux 2.5.19; was %lu before Linux 2.6.22) (41) *) delayacct_blkio_ticks : int64; (* %llu (since Linux 2.6.18) (42) *) guest_time : int64; (* %lu (since Linux 2.6.24) (43) *) cguest_time : int64; (* %ld (since Linux 2.6.24) (44) *) } (* type stat *) type stat_alias = stat type easy_stat = < pid:int; comm:string; state:char; ppid:int; pgrp:int; session:int; tty_nr:int; tpgid:int; other_fields:string > let stat_constructor pid comm state ppid pgrp session tty_nr tpgid flags minflt cminflt majflt cmajflt utime stime cutime cstime priority nice num_threads itrealvalue starttime vsize rss (rsslim:string) startcode endcode startstack kstkesp kstkeip signal blocked sigignore sigcatch (wchan:string) nswap cnswap exit_signal processor rt_priority policy delayacct_blkio_ticks guest_time cguest_time = let rsslim = try Some (Int64.of_string rsslim) with _ -> None in let wchan = try Some (Int64.of_string wchan) with _ -> None in { pid=pid; comm=comm; state=state; ppid=ppid; pgrp=pgrp; session=session; tty_nr=tty_nr; tpgid=tpgid; flags=flags; minflt=minflt; cminflt=cminflt; majflt=majflt; cmajflt=cmajflt; utime=utime; stime=stime; cutime=cutime; cstime=cstime; priority=priority; nice=nice; num_threads=num_threads; itrealvalue=itrealvalue; starttime=starttime; vsize=vsize; rss=rss; rsslim=rsslim; startcode=startcode; endcode=endcode; startstack=startstack; kstkesp=kstkesp; kstkeip=kstkeip; signal=signal; blocked=blocked; sigignore=sigignore; sigcatch=sigcatch; wchan=wchan; nswap=nswap; cnswap=cnswap; exit_signal=exit_signal; processor=processor; rt_priority=rt_priority; policy=policy; delayacct_blkio_ticks=delayacct_blkio_ticks; guest_time=guest_time; cguest_time=cguest_time; } let input_line_from_file filename = try let ch = open_in filename in let result = try Some (input_line ch) with _ -> None in let () = close_in ch in result with _ -> None let stat pid = let filename = Printf.sprintf "/proc/%d/stat" pid in Option.bind (input_line_from_file filename) begin fun line -> try let obj = (try Scanf.sscanf line (* 0 1 2 3 4 *) (* 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 *) "%d %s %c %d %d %d %d %d %Lu %Lu %Lu %Lu %Lu %Lu %Lu %Ld %Ld %Ld %Ld %Ld %Ld %Lu %Lu %Ld %s %Lu %Lu %Lu %Lu %Lu %Lu %Lu %Lu %Lu %s %Lu %Lu %d %d %Lu %Lu %Lu %Lu %Ld" stat_constructor with _ -> Scanf.sscanf line "%d (%s@) %c %d %d %d %d %d %Lu %Lu %Lu %Lu %Lu %Lu %Lu %Ld %Ld %Ld %Ld %Ld %Ld %Lu %Lu %Ld %s %Lu %Lu %Lu %Lu %Lu %Lu %Lu %Lu %Lu %s %Lu %Lu %d %d %Lu %Lu %Lu %Lu %Ld" stat_constructor) in Some obj with Scanf.Scan_failure(msg) -> (Printf.kfprintf flush stderr "Linux.stat: failed scanning file %s: %s\n" filename msg; None) end let easy_stat pid = let easy_stat_constructor pid comm state ppid pgrp session tty_nr tpgid other_fields = object method pid=pid; method comm=comm; method state=state; method ppid=ppid; method pgrp=pgrp; method session=session; method tty_nr=tty_nr; method tpgid=tpgid; method other_fields=other_fields; end in let filename = Printf.sprintf "/proc/%d/stat" pid in Option.bind (input_line_from_file filename) begin fun line -> try let obj = (try Scanf.sscanf line "%d %s %c %d %d %d %d %d %s@\n" easy_stat_constructor with _ -> Scanf.sscanf line "%d (%s@) %c %d %d %d %d %d %s@\n" easy_stat_constructor) in Some obj with Scanf.Scan_failure(msg) -> (Printf.kfprintf flush stderr "Linux.easy_stat: failed scanning file %s: %s\n" filename msg; None) end let get_proc_PID_directories () = let xs = UnixExtra.Dir.to_list ~entry_kind:Unix.S_DIR "/proc/" in let ys = List.filter (fun x -> Sys.file_exists (Printf.sprintf "/proc/%s/stat" x)) xs in let zs = ListExtra.filter_map (fun y -> try Some (int_of_string y) with _ -> None) ys in zs (* Make a multimap: ppid -> children *) module Int_key = struct type t = int let compare = Pervasives.compare end module Int_elt = Int_key module Parent_children_multimap : Multimap.S with type key = Int_key.t and type elt = Int_elt.t and type elt_set = SetExtra.Make(Int_elt).t = Multimap.Make(Int_key)(Int_elt) (* Functor making exported functions for both types (`stat' and `easy_stat')*) module Make_descendant_stats_functions (M:sig type stat val stat : pid -> stat option val ppid_prj : stat -> pid val pid_prj : stat -> pid end) = struct let get_stats () = let zs = get_proc_PID_directories () in ListExtra.filter_map (M.stat) zs module Pid_stat_map = MapExtra.Make (Int_key) let get_parent_children_multimap_and_stat_map () = let os = get_stats () in let ppid_pid_bindings = List.map (fun o -> (M.ppid_prj o), (M.pid_prj o)) os in let pid_stat_bindings = List.map (fun o -> (M.pid_prj o), o) os in (* Make the multimap: ppid -> children *) let mmap = Parent_children_multimap.of_list (ppid_pid_bindings) in (* Make the map: ppid -> stat *) let map = Pid_stat_map.of_list (pid_stat_bindings) in (mmap, map) (* Note that this implementation is close but not strictly equivalent to map (with List.map) the function `stat' over the list resulting from `get_descendants'. Actually, with this version the files /proc/%s/stat are read *once*, not twice: *) let get_descendant_stats ?(pid=Unix.getpid ()) () = let mmap, map = get_parent_children_multimap_and_stat_map () in let rec loop ppid = let children = Parent_children_multimap.find_list ppid mmap in List.concat (List.map (fun pid -> pid::(loop pid)) children) in let descendants = loop pid in let precalculated_stat pid = Pid_stat_map.find pid map in List.map (precalculated_stat) descendants (* Optimized as `get_descendant_stats' (see the previous comment): *) let get_descendant_stats_as_forest ?(pid=Unix.getpid ()) () = let mmap, map = get_parent_children_multimap_and_stat_map () in let successors ppid = Parent_children_multimap.find_list ppid mmap in let (_pid, descendants_as_forest) = Forest.tree_of_acyclic_relation ~successors ~root:pid in let precalculated_stat pid = Pid_stat_map.find pid map in Forest.map (precalculated_stat) (descendants_as_forest) let get_parent_children_multimap () = let os = get_stats () in let ppid_pid_bindings = List.map (fun o -> (M.ppid_prj o), (M.pid_prj o)) os in (* Make the multimap: ppid -> children *) let mmap = Parent_children_multimap.of_list (ppid_pid_bindings) in mmap let get_descendants ?(pid=Unix.getpid ()) () = let mmap = get_parent_children_multimap () in let rec loop ppid = let children = Parent_children_multimap.find_list ppid mmap in List.concat (List.map (fun pid -> pid::(loop pid)) children) in loop pid let get_descendants_as_forest ?(pid=Unix.getpid ()) () = let mmap = get_parent_children_multimap () in let successors ppid = Parent_children_multimap.find_list ppid mmap in let (_pid, forest) = Forest.tree_of_acyclic_relation ~successors ~root:pid in forest let get_children ?(pid=Unix.getpid ()) () = let mmap = get_parent_children_multimap () in Parent_children_multimap.find_list pid mmap end (* functor Make_descendant_stats_functions *) module Easy_stat = Make_descendant_stats_functions (struct type stat = easy_stat let stat = easy_stat let ppid_prj x = x#ppid let pid_prj x = x#pid end) let get_easy_stats = Easy_stat.get_stats let get_descendant_easy_stats = Easy_stat.get_descendant_stats let get_descendant_easy_stats_as_forest = Easy_stat.get_descendant_stats_as_forest (* The following functions are based on `easy_stat' because with this type there are less chances of scan failures: *) let get_children = Easy_stat.get_children let get_descendants = Easy_stat.get_descendants let get_descendants_as_forest = Easy_stat.get_descendants_as_forest module Full_stat = Make_descendant_stats_functions (struct type stat = stat_alias let stat = stat let ppid_prj x = x.ppid let pid_prj x = x.pid end) let get_stats = Full_stat.get_stats let get_descendant_stats = Full_stat.get_descendant_stats let get_descendant_stats_as_forest = Full_stat.get_descendant_stats_as_forest module Kill_descendants = struct let still_alive_after_kill ~signal ~wait_delay pid_list = if pid_list = [] then [] (* return *) else (* continue *) let () = List.iter (fun pid -> try Unix.kill pid signal with _ -> ()) pid_list in (* Leave to the fathers the time to register the death of their children: *) let () = Thread.delay wait_delay in let alive_list = List.filter (UnixExtra.is_process_alive) pid_list in alive_list let killall ?(signal_sequence=[Sys.sigterm; Sys.sigint; Sys.sigcont; Sys.sigkill]) ?(wait_delay=0.1) ?(wait_delay_factor=2.) ?(retries=1) pids = let rec loop i wait_delay = let alive_list = pids in if i > retries then () (* abandon *) else let alive_list = List.fold_left (fun alive_list signal -> still_alive_after_kill ~signal ~wait_delay alive_list) (alive_list) (signal_sequence) in if alive_list = [] then () else loop (i+1) (wait_delay *. wait_delay_factor) in loop 1 wait_delay let kill_descendants ?sequential ?(wait_delay=0.1) ?(wait_delay_node_increase_factor=2.) ?(wait_delay_root_increase_factor=2.) ?(node_max_retries=1) ?(root_max_retries=1) ?signal_sequence ?(pid=Unix.getpid ()) () = let rec main_loop j wait_delay = if j > root_max_retries then () (* abandon *) else let f0 = get_descendant_stats_as_forest ~pid () in if Forest.is_empty f0 then () (* stop *) else (* continue *) (* The last launched will be the first killed: *) let f1 = Forest.sort (fun p1 p2 -> compare p2.starttime p1.starttime) f0 in (* The forest evaluation function: *) let eval x = function (* Leaf evaluation: do nothing, just provide the pid to the father *) | [] -> x.pid (* Node evaluation: kill children, then provide the pid to the father *) | x_children -> let () = killall ?signal_sequence ~wait_delay ~wait_delay_factor:(wait_delay_node_increase_factor) ~retries:(node_max_retries) x_children in x.pid in let backprop = match sequential with | None -> Forest.backprop_parallel | Some () -> Forest.backprop in let children = backprop eval f1 in let () = killall ?signal_sequence ~wait_delay ~wait_delay_factor:(wait_delay_node_increase_factor) ~retries:(node_max_retries) children in main_loop (j+1) (wait_delay *. wait_delay_root_increase_factor) in main_loop 1 (wait_delay) end (* Kill_descendants *) include Kill_descendants end (* Process *) let processor_no = lazy begin let filename = "/proc/cpuinfo" in try let ch = open_in filename in let rec loop k = try let line = input_line ch in let sub = try (String.sub line 0 9) with _ -> "" in let k = if (sub = "processor") then (k+1) else k in loop k with End_of_file -> k in let result = loop 0 in let () = close_in ch in result with _ -> 1 (* I suppose there is one processor... *) end ocamlbricks-0.90+bzr456.orig/SHELL/wrapper.ml0000644000175000017500000001707013175721005017611 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Handling shell scripts in {e OCaml}. A general technique for wrapping shell commands or scripts is proposed in this module. The technique is applied in the module {!Shell} for building a significative set of ready-to-use wrappers corresponding to the most famous {e Unix} tools ({b grep}, {b dd}, {b tar},..). *) open Sugar;; (** A {e command} is a string. *) type command = string;; (** A {e content} is a string. *) type content = string;; (** An {e argument} is a string. *) type arg = string ;; (** A {e call} is a directly executable command, as for instance, ["ls"] or ["wc -l"] or ["cat | grep -v"]. *) type call = string;; (** A {e script} is a command containing some positional parameters [$1], [$2],... as for instance ["test -d $1 && echo true"]. A script is not directly executable but can be easily {e enveloped} in a shell function in order to become executable by the shell interpreter. *) type script = string;; (** {2 Envelop} *) (** Envelop a script into a function followed by a call of this function. {b Example}: {[# print_endline (envelop "test -d $1");; function auxfun418234 () { test -d $1 } auxfun418234 : unit = () ]}*) let envelop ?(name:string=("auxfun"^(string_of_int (Random.int 819200)))) (script:script) : call = ("function "^name^" () {\n"^script^"\n}\n"^name) ;; (** {2 Wrapper} *) (** {[ ?args:'a | +-----+-----+ | ?at | argument(s) ?opt +-----+-----+ treatment | | +----------+--+ +-----------+ | Unix.shell | +-----------+ ?input:'b -->+ ?it +-------->+ +-------->+ ~ot +-->'c +-----------+ | command | +-----------+ input treatment +-------------+ output treatment ]} *) (** General constructor for shell encapsulation: - the function [~it] (the {e input treatment}, by default [None]) represent the action to execute before the [command], in order to transform a value of a type ['b] into a [string]; the result will be used as {b standard input} for the [command]; - the function [~ot] (the {e output treatment}) represent the action to execute after the [command] in order to transform its {b standard output} (a [string]) in a value of an arbitrary type ['c]; - the function [~at] (the {e argument treatment}, by default [None]) permits a similar re-arrangement of the signature, but for the argument(s) of the command, which could be of any type ['a] (then also a tuple). This function converts the argument(s) in a string, which is the suitable type for the [command]; - options (by default [~opt=""]) are appended as-is at right side of the command and before the string representation of arguments. If the flag [~script] is set the [command] is enveloped in order to allow the use of positionnal parameters [$1], [$2],... By default [~script=false]. The function raises a failure if an argument or an input is provided (in the form [Some v]) while the corresponding treatment is undefined (equals to [None]). *) let make ?(at:(('c->string) option)=None) ?(it:(('a->string) option)=None) ~(ot:(string->'b)) ?(script=false) (cmd:command) ?(opt="") ?(args:('c option)=None) ?(input:('a option)=None) () = let cmd = if script then envelop cmd else cmd in let perform_treat t x = match (t,x) with | ((Some f), (Some x)) -> (f x) | ( _ , None) -> "" | ( None , (Some x)) -> failwith "Wrapper.make: argument provided without a treatment" in let args = perform_treat at args in let input = perform_treat it input in (cmd^" "^opt^" "^args^"\n") => ((UnixExtra.shell ~trace:false ~input) || ot ) ;; (** {3 Text filters} *) (** This constructor represent a specialization of the function {!make} for building wrappers dealing with texts (string lists): - the input treatment [~it] is set to [Some String.Text.to_string] - the output treatment [~ot] is set to [String.Text.of_string] *) let textfilter ?(at:(('c->string) option)=None) ?(script=false) (cmd:command) ?(opt="") ?(args:('c option)=None) (x:string list) = make ~at ~script ~it:(Some StringExtra.Text.to_string) ~ot:StringExtra.Text.of_string cmd ~opt ~args ~input:(Some x) ();; (** {2 Treatments} *) (** Common treatments for parameters, inputs and outputs. All treatments are value of the type [('a -> 'b) option]. *) module Treat = struct (* {b Input/Argument treatments} *) (** Nothing to do (identity function). *) let identity = Some (fun x->x) ;; (** Simple quote the argument. Sometimes, the argument of the filter must be envelopd into simple quotes, as for [awk] and [sed], in order to prevent problems with special chars. *) let quote = Some (fun x -> "'"^x^"'");; (* {b Output treatments} *) (** Make your boolean scripts with this output treatment *) let is_true = (StringExtra.chop || ((=) "true")) ;; end;; (* module Treat *) (** {2 Examples} Basically, the wrapper constructor may be used in a "quick and easy" way using strings as parameters of the resulting wrapper. Instead, the more sofisticated way constists in defining a real abstract syntax for parameters and/or inputs, in order to avoid bad calls of the wrapper at compile-time. *) (** {3 Quick and easy wrapper} *) (**{[ (* A wrapper for the command date *) let date ?(opt="") ?(arg="") () = make ~at:Treat.identity ~ot:String.chop "date" ~args:(Some arg) ~opt () ;; (* Examples of usage: *) # date () ;; : string = "lun avr 16 14:28:57 CEST 2007" # date ~opt:"-r" ~arg:"shell.ml" () ;; : string = "sam avr 14 16:58:22 CEST 2007" # date ~arg:"-r shell.ml" () ;; : string = "sam avr 14 16:58:22 CEST 2007" ]} *) (** {3 A more sofisticated wrapper} *) (**{[ (* A wrapper for the command date with an abstract syntax for parameters. *) module Date = struct (* (1) Define your abstract syntax (for parameters and/or input and/or output). In this case for parameters: *) type options = Option_f of string | Option_r of string | Option_R ;; type synopsis = options list ;; (* (2) Define your conversion(s) *) let string_of_options = function | Option_f x -> "-f "^x | Option_r x -> "-r "^x | Option_R -> "-R " ;; let string_of_synopsis = String.merge_map string_of_options;; (* (3) Apply the wrapper constructor *) let date (args:synopsis) = make ~at:(Some string_of_synopsis) ~ot:String.chop "date" ~args:(Some args) () ;; end;; (* Example of usage *) # date [Option_r "shell.ml"];; : string = "sam avr 14 16:58:22 CEST 2007" ]}*) ocamlbricks-0.90+bzr456.orig/WIDGETS/0000755000175000017500000000000013175721005016031 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/WIDGETS/environments.mli0000644000175000017500000000313013175721005021260 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo, Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Abstract results of a GUI dialog. *) class ['a, 'b] env : unit -> object val table : ('a, 'b) Hashmap.t method add : 'a * 'b -> unit method add_list : ('a * 'b) list -> unit method get : 'a -> 'b method to_list : ('a * 'b) list method updated_by : ('a,'b) env -> unit end val make : ('a * 'b) list -> ('a, 'b) env exception Undefined_identifier of string class ['a] string_env : unit -> object val table : (string, 'a) Hashmap.t method add : string * 'a -> unit method add_list : (string * 'a) list -> unit method get : string -> 'a method to_list : (string * 'a) list method to_string : ('a -> string) -> string method updated_by : (string,'a) env -> unit end val make_string_env : (string * 'a) list -> 'a string_env val string_env_updated_by: 'a string_env -> 'a string_env -> 'a string_env ocamlbricks-0.90+bzr456.orig/WIDGETS/widget.mli0000644000175000017500000001400613175721005020020 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo Trivial change in 2008 by Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Some generic tools for building GUIs *) module Image : sig val scaleTo : int * int -> GdkPixbuf.pixbuf -> GdkPixbuf.pixbuf val zoom : float -> GdkPixbuf.pixbuf -> GdkPixbuf.pixbuf val inch_of_pixels : ?ppi:float -> int -> float end module DynamicSubmenu : sig val make : ?set_active:(string -> bool) -> submenu:GMenu.menu -> menu:GMenu.image_menu_item -> dynList:(unit -> string list) -> action:(string -> unit -> unit) -> unit -> unit end module ComboTextTree : sig class comboTextTree : generator:(string Environments.string_env -> string list) -> msg:string Environments.string_env -> key:string -> callback:(string -> unit) option -> packing:(GObj.widget -> unit) option -> object method add_child : comboTextTree -> unit method box : GEdit.combo_box method callback : string -> unit method changedAndGetActive : (string -> unit) -> unit method child : int -> comboTextTree method children : comboTextTree list method children_rebuild : unit -> unit method choices : string list method col : string GTree.column method env : string Environments.string_env method generator : string Environments.string_env -> string list method initialize_callbacks : unit method key : string method packing : GObj.widget -> unit method rebuild : string Environments.string_env -> unit method selected : string method set_active_value : string -> unit method set_box : GEdit.combo_box -> unit method set_children : comboTextTree list -> unit method set_choices : string list -> unit method set_col : string GTree.column -> unit method set_env : string Environments.string_env -> unit method slave : comboTextTree method slave0 : comboTextTree method slave1 : comboTextTree method slave2 : comboTextTree method slave3 : comboTextTree method slave4 : comboTextTree method slave5 : comboTextTree end type choice = string type choices = choice list val make : generator:(choice Environments.string_env -> choice list) -> msg:choice Environments.string_env -> key:string -> callback:(choice -> unit) option -> packing:(GObj.widget -> unit) option -> comboTextTree val fromList : ?key:string -> ?callback:(choice -> unit) option -> ?packing:(GObj.widget -> unit) option -> choices -> comboTextTree val fromListWithSlave : ?masterCallback:(choice -> unit) option -> ?masterPacking:(GObj.widget -> unit) option -> choices -> ?slaveCallback:(choice -> unit) option -> ?slavePacking:(GObj.widget -> unit) option -> (choice -> choices) -> comboTextTree val fromListWithSlaveWithSlave : ?masterCallback:(choice -> unit) option -> ?masterPacking:(GObj.widget -> unit) option -> choices -> ?slaveCallback:(choice -> unit) option -> ?slavePacking:(GObj.widget -> unit) option -> (choice -> choices) -> ?slaveSlaveCallback:(choice -> unit) option -> ?slaveSlavePacking:(GObj.widget -> unit) option -> (choice -> choice -> choices) -> comboTextTree val fromListWithSlaveWithSlaveWithSlave : ?masterCallback:(choice -> unit) option -> ?masterPacking:(GObj.widget -> unit) option -> choices -> ?slaveCallback:(choice -> unit) option -> ?slavePacking:(GObj.widget -> unit) option -> (choice -> choices) -> ?slaveSlaveCallback:(choice -> unit) option -> ?slaveSlavePacking:(GObj.widget -> unit) option -> (choice -> choice -> choices) -> ?slaveSlaveSlaveCallback:(choice -> unit) option -> ?slaveSlaveSlavePacking:(GObj.widget -> unit) option -> (choice -> choice -> choice -> choices) -> comboTextTree val fromListWithTwoSlaves : ?masterCallback:(choice -> unit) option -> ?masterPacking:(GObj.widget -> unit) option -> choices -> ?slave0Callback:(choice -> unit) option -> ?slave0Packing:(GObj.widget -> unit) option -> (choice -> choices) -> ?slave1Callback:(choice -> unit) option -> ?slave1Packing:(GObj.widget -> unit) option -> (choice -> choices) -> comboTextTree val fromListWithThreeSlaves : ?masterCallback:(choice -> unit) option -> ?masterPacking:(GObj.widget -> unit) option -> choices -> ?slave0Callback:(choice -> unit) option -> ?slave0Packing:(GObj.widget -> unit) option -> (choice -> choices) -> ?slave1Callback:(choice -> unit) option -> ?slave1Packing:(GObj.widget -> unit) option -> (choice -> choices) -> ?slave2Callback:(choice -> unit) option -> ?slave2Packing:(GObj.widget -> unit) option -> (choice -> choices) -> comboTextTree end class textview : ?view:GText.view -> unit -> object method append : ?tags:string list -> string -> unit method append_image : ?scale:(int * int) option -> string -> unit method private create_tags : unit -> unit method delete : unit -> unit method refresh : unit -> unit method rewrite : ?tags:string list -> string -> unit method view : GText.view end ocamlbricks-0.90+bzr456.orig/WIDGETS/environments.ml0000644000175000017500000000700013175721005021107 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo, Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* **************************************** * Class Env * **************************************** *) (** The class of environments. An ('a,'b) environment is a set of pairs, where key is of type 'a and value of type 'b. A single environment can't contain more than a single binding for each key. *) class ['a,'b] env = fun () -> object (self) (** The internal representation of an environment. *) val table : ('a, 'b) Hashmap.t = Hashmap.make () (** Convert into a list of pairs. *) method to_list = Hashmap.to_list table (** Add a list of binding to the environment. *) method add_list xs = Hashmap.add_list table xs (** High level accessors. *) (** Get the value associated to the given id (key). *) method get id = Hashmap.lookup table id (** Add a pair (identifier,value) to the environment. *) method add (id,v) = Hashmap.add table id v (** Update the environment (self) by another environment which will "cover" previous links.*) method updated_by (e:(('a,'b) env)) : unit = List.iter (self#add) (e#to_list) end;; (** Simple constructor for environments.*) let make (l:('a*'b) list) = let e=(new env ()) in (e#add_list l); e;; (* **************************************** * Class string_env * **************************************** *) (** {2 String environments } The special (and quite common) case where keys are strings allows the user to better trace failures of the `get' method. *) exception Undefined_identifier of string class ['b] string_env () = object (self) inherit [string,'b] env () as super method get id = try (super#get id) with Not_found -> raise (Undefined_identifier id) (** {b Example}: {[# let e = Environment.make_string_env [("aaa", 1); ("bbbbbb",2); ("c",3) ] ;; val e : int Environment.string_env = # Printf.printf "%s" (e#to_string (string_of_int)) ;; bbbbbb = 2 c = 3 aaa = 1 : unit = () ]} *) method to_string string_of_alpha = match self#to_list with | [] -> "" | xs -> let domain = List.map fst xs in let max_length = ListExtra.max (List.map String.length domain) in let ys = List.map (fun (k,v) -> let k' = String.make max_length ' ' in String.blit k 0 k' 0 (String.length k); (Printf.sprintf "%s = %s\n" k' (string_of_alpha v))) xs in List.fold_left (^) (List.hd ys) (List.tl ys) end;; (** Simple constructor for string environments.*) let make_string_env (l:(string*'b) list) = let e=(new string_env ()) in (e#add_list l); e;; let string_env_updated_by (r:'a string_env) (r':'a string_env) = let () = r#updated_by (r' :> (string,'a) env) in r ocamlbricks-0.90+bzr456.orig/WIDGETS/widget.ml0000644000175000017500000006071513175721005017657 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Jean-Vincent Loddo Trivial change in 2008 by Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Some generic tools for building GUIs *) open Sugar;; (** {2 Image manipulations } *) (** Module for managing images. *) module Image = struct (** Scale the given image at the given size (width,height). @return a new image *) let scaleTo (width,height) pixbuf = begin let scaled = GdkPixbuf.create ~has_alpha:true ~width ~height () in (* GdkPixbuf.scale ~dest:scaled ~width ~height ~interp:`BILINEAR pixbuf; *) GdkPixbuf.scale ~dest:scaled ~width ~height ~interp:`HYPER pixbuf; scaled end ;; (** Make a zoom of the given image with the given factor (>1 => zoom IN, <1 => zoom OUT). @return a new image *) let zoom (factor:float) pixbuf = let formule = (fun x -> (float_of_int x) *. factor +. 0.5 ) || int_of_float in let width = pixbuf => (GdkPixbuf.get_width || formule) in let height = pixbuf => (GdkPixbuf.get_height || formule) in prerr_endline ("Old width="^(string_of_int (GdkPixbuf.get_width pixbuf))); prerr_endline ("Old height="^(string_of_int (GdkPixbuf.get_height pixbuf))^"\n"); scaleTo (width,height) pixbuf ;; (** The pixels to inch conversion: ppi stands for pixel-per-inch *) let inch_of_pixels ?(ppi=96.) (x:int) = (float_of_int x) /. ppi ;; end;; (* module Image *) (** {2 Dynamic submenus } *) (** Module for building dynamic {e submenus}. A {e submenu} is a menu included in another menu. *) module DynamicSubmenu = struct (** Makes a dynamic submenu of a given menu (the {e father}). When the father is activated, the submenu entries are recalculated with the given function ([dynList]). Exemple: {[make ~submenu:w#MACHINE_ELIM_menu ~menu:w#MACHINE_ELIM ~dynList:machineList ~action:(fun x ->fun _ -> prerr_endline x) ;; ]} *) let make ?(set_active:(string->bool)=(fun x->false)) ~(submenu: GMenu.menu) ~(menu: GMenu.image_menu_item) ~(dynList: unit->(string list)) ~(action: string->unit->unit) () = let recalc () = ( List.iter (submenu#remove) (submenu#children) ; List.iter (fun x -> let i=(GMenu.check_menu_item ~active:(set_active x) ~label:x ~packing:(submenu#add) ()) in let _ = i#connect#toggled ~callback:(action x) in () ) (dynList ()) ) in let _ = menu#connect#activate ~callback:recalc in () ;; end;; (* Module DynamicSubmenu *) (* ********************************* * Module ComboTextTree comboTextTree class & constructors * ********************************* *) (** {2 ComboText Trees} *) (** Module for building a set (structured in a tree hierarchy) of dependent combo texts. Any change of the selected value of a particular node, cause the rebuilding of the choice list of all its descendents in the tree. *) module ComboTextTree = struct (** {2 Class definition} *) (** A ComboTextTree is a combo with eventually some dependent {i children} (or {i slaves}). The choice list of a node in the tree depends on the father's selected value and on the ancestors's selected values. The list of choices of a node is given dynamically by a function called the {i generator} which is used to calculte or recalculate the choice list. *) class comboTextTree = fun (* The option generator. May be a constant function as particular case. *) ~(generator: string Environments.string_env -> string list) (* The first input for the generator. *) ~(msg:string Environments.string_env) (* The key of the pair (key,value) send to its children. *) ~(key:string) (* An optional callback function, to call at any change *) ~(callback:(string->unit) option) (* The packing function. *) ~(packing:(GObj.widget -> unit) option) -> (* Build the initial combo list (no packing and no callback are defined here (because self dont exist at this stage). *) let strList = (generator msg) in let (initial_box, (_, initial_col)) = GEdit.combo_box_text ~strings:strList () in let _ = initial_box#set_active 0 in object (self) (** Constant fields (methods) *) (** The function to build or rebuild the choices using the given environnement. For a simple comboTextTree, this method is used only at the creation and the function is not really dependent from its argument, but it is a simple costant function. *) method generator : (string Environments.string_env -> string list) = generator (** The key of the pair (key,value) which this widget (node) eventually transmit to its children (slaves). This field is set at the creation. The value of the pair (key,value) will be the selected value of the widget, of course. *) method key : string = key (** A secondary function to call at any change of the selected item. This represent an additional callback. The principal callback is the method [children_rebuild] which propagate the selected value to all children. *) method callback : (string -> unit) = match callback with None -> (fun x->()) | Some f -> f (** The function to call to attach self somewhere. For instance : {[ packing = dialog#table#attach ~left:1 ~top:2 ~right:3 ]} Every time the comboTextTree is rebuilt, the old box is destroyed, rebuilt and finally repackaged with this packing function. *) method packing : (GObj.widget -> unit) = match packing with None -> (fun x->()) | Some f -> f (** Variable fields *) (** This fields stores the environment used for the last generation of the choice list. This information is fundamental because if this widget has some ancestors and also some descendents, for any alteration of its state, it must resend to its children the last environment received from its ancestors enriched with the pair (key,value) representing its own state. In this way, every descendent know the state of all its ancestors (not only the state of its father). *) val mutable env : (string Environments.string_env) = msg (** The choices calculated by the last call to the generator. *) val mutable choices : (string list) = (generator msg) (** The currently encapsulated [GEdit.combo_box]. *) val mutable box : #GEdit.combo_box = initial_box val mutable col : ('a GTree.column) = initial_col (** The children list of this widget. *) val mutable children : comboTextTree list = [] (** Accessors *) method env = env method choices = choices method box = box method col = col method children = children method child i = List.nth children i (** Convenient aliases *) method slave = List.nth children 0 method slave0 = List.nth children 0 method slave1 = List.nth children 1 method slave2 = List.nth children 2 method slave3 = List.nth children 3 method slave4 = List.nth children 4 method slave5 = List.nth children 5 (** Fixing variable fields *) method set_env r = env <- r method set_choices l = choices <- l method set_box b = box <- b method set_col c = col <- c method set_children l = children <- l method add_child x = children <- children @ [x] (** Selected item *) (** In the most cases, {b the only interesting method} from an abstract point of view. @return the selected string belong the combo items *) method selected = match self#box#active_iter with | None -> "" | Some row -> (self#box#model#get ~row ~column:self#col) (** Set the current active (selected) choice by its value (instead of its index) *) method set_active_value (v:string) = try let i = Option.extract (ListExtra.indexOf v self#choices) in self#box#set_active i ; self#children_rebuild () with _ -> () (** Rebuilding self and children *) (** Demands to all children to rebuild theirself and their children and so on. This procedure is performed sending to all children the ancestor environment (method [env]) enriched by the pair (key,value), where value is the current selected item of this node. *) method children_rebuild () = let msg = Environments.make_string_env (self#env#to_list @ [(self#key,self#selected)]) in (* x = self#selected *) List.iter (fun w -> w#rebuild msg) self#children (** Rebuild this widget, and its eventually all children, with the new given environment. *) method rebuild (msg : string Environments.string_env) = begin (* Save the current selected choice. We will try to reset it. *) let previous = self#selected in (* Destroy the old combo box. *) self#box#destroy () ; (* Essentiel! *) (* Rebuild combo list. *) let strList = (self#generator msg) in let (combo, (_, column)) = GEdit.combo_box_text ~strings:strList () in self#set_box combo ; self#set_col column ; self#set_choices strList ; self#initialize_callbacks ; (* Re-initialize callbacks for the new box! *) self#packing (self#box :> GObj.widget) ; (* repack self *) (* Register the last master environment *) self#set_env msg ; (* Try to restore the previous selected value (or select the index 0) *) let i = ((ListExtra.indexOf previous self#choices) |=> 0) in (self#box#set_active i) ; (* Propagate to its children. *) self#children_rebuild () ; () end (**/**) (* STOP DOC *) (* Procédure de connection de l'élement changed d'un combo à un callback qui permet de faire appel à un second callback (cbackfun), de type string->unit, sur la chaine selectionnée dans le widget. *) method changedAndGetActive (cbfun:string->unit) = let _ = self#box#connect#changed (fun () -> match self#box#active_iter with | None -> () | Some row -> let data = (self#box#model#get ~row ~column:self#col) in cbfun data ) in () (* The packing initialization (only for bootstrap). *) val initialize_packing = let _ = match packing with None -> () | Some f -> f (initial_box :> GObj.widget) in () (* This method must be called by a constructor after the bootstrap. These action cannot be placed in the boostrap of the instance. *) method initialize_callbacks = let _ = self#changedAndGetActive (fun x -> self#children_rebuild ()) in (** First connect the standard callback. *) let _ = self#changedAndGetActive self#callback in () (** Second connect the given callback. *) end;; (* class comboTextTree *) (** {2 Constructors and convenient API} *) (** A choice is simply a string. *) type choice = string;; (** The type [choices] represent a [choice list], of course. *) type choices = choice list;; (** The simplest and general constuctor. Simply calls the class constructor and initialize callbacks. *) let make ~(generator: (string Environments.string_env)->(string list)) (** The option generator. May be a constant function as particular case. *) ~(msg:string Environments.string_env) (** The input for the generator. *) ~(key:string) (** The key of the pair (key,value) send to its children. *) ~(callback:(choice->unit) option) (** An optional callback function, to call at any change *) ~(packing:(GObj.widget -> unit) option) (** The packing function. *) = let self = new comboTextTree ~generator ~msg ~key ~callback ~packing in let _ = self#initialize_callbacks in self ;; (** Make a simple combo text with no children. You can specify a [key] (if you plan to affect some children to this widget) and an additional [callback] fonction of type [choice -> unit], which will be called every time the user will modify its selection. You also can specify a packing function. Examples: - {[ let colors = fromList ["red"; "blue"; "black"] ;; ]} - {[ let colors = fromList ~packing:(Some (dialog#table#attach ~left:2 ~top:6 ~right:4)) ["red"; "blue"; "black"] ]} *) let fromList ?(key:string="unused_key") ?(callback:((choice->unit) option) = None ) ?(packing:((GObj.widget -> unit) option) = None ) (lst:choices) = let g = (fun r -> lst) in let m = (Environments.make_string_env []) in make ~generator:g ~msg:m ~key ~callback ~packing ;; (** {3 Combo chains} *) (** {b Modelling a dependent chain of widgets: {v master -> slave -> slave -> .. v} } *) (** Make a two level chain of dependent combos text. You can access to the slave simply writing [master#slave] ([slave] is simply an alias for the child number 0). Example : {[ let distrib = fromListWithSlave ~masterPacking: (Some (dialog#table#attach ~left:2 ~top:4 ~right:4)) ["debian";"redhat";"suse"] ~slavePacking: (Some (dialog#table#attach ~left:2 ~top:5 ~right:4)) MSys.patchListOf ;; ]} *) let fromListWithSlave ?(masterCallback:((choice->unit) option) = None) ?(masterPacking:((GObj.widget -> unit) option) = None) (masterChoices:choices) ?(slaveCallback:((choice->unit) option) = None) ?(slavePacking:((GObj.widget -> unit) option) = None ) (slaveChoices: choice -> choices) = let master = fromList ~key:"master" ~callback:masterCallback ~packing:masterPacking masterChoices in let slave = make ~generator:(fun r -> slaveChoices (r#get "master")) ~msg:(Environments.make_string_env [("master",master#selected)]) ~key:"slave" ~callback:slaveCallback ~packing:slavePacking in let _ = master#add_child slave in master (* Here you set the dependency. *) ;; (** Make a 3 levels chain of dependent combos text. You can access the slave simply writing [master#slave], and the slave of the slave simply writing [master#slave#slave]. *) let fromListWithSlaveWithSlave ?(masterCallback:((choice->unit) option) = None) ?(masterPacking:((GObj.widget -> unit) option) = None) (masterChoices:choices) ?(slaveCallback:((choice->unit) option) = None) ?(slavePacking:((GObj.widget -> unit) option) = None ) (slaveChoices: choice -> choices) ?(slaveSlaveCallback:((choice->unit) option) = None) ?(slaveSlavePacking:((GObj.widget -> unit) option) = None ) (slaveSlaveChoices: choice -> choice -> choices) = let master = fromListWithSlave ~masterCallback ~masterPacking masterChoices ~slaveCallback ~slavePacking slaveChoices in let slaveSlave = make ~generator:(fun r -> slaveSlaveChoices (r#get "master") (r#get "slave")) ~msg:(Environments.make_string_env [("master",master#selected);("slave",master#slave#selected)]) ~key:"slaveSlave" ~callback:slaveSlaveCallback ~packing:slaveSlavePacking in (* Here you set the dependency: *) let _ = master#slave#add_child slaveSlave in master ;; (** Make a 4 levels chain of dependent combos text. You can access the slave chain simply by [master#slave], [master#slave#slave] and [master#slave#slave#slave].*) let fromListWithSlaveWithSlaveWithSlave ?(masterCallback:((choice->unit) option) = None) ?(masterPacking:((GObj.widget -> unit) option) = None) (masterChoices:choices) ?(slaveCallback:((choice->unit) option) = None) ?(slavePacking:((GObj.widget -> unit) option) = None ) (slaveChoices: choice -> choices) ?(slaveSlaveCallback:((choice->unit) option) = None) ?(slaveSlavePacking:((GObj.widget -> unit) option) = None ) (slaveSlaveChoices: choice -> choice -> choices) ?(slaveSlaveSlaveCallback:((choice->unit) option) = None) ?(slaveSlaveSlavePacking:((GObj.widget -> unit) option) = None ) (slaveSlaveSlaveChoices: choice -> choice -> choice -> choices) = let master = fromListWithSlaveWithSlave ~masterCallback ~masterPacking masterChoices ~slaveCallback ~slavePacking slaveChoices ~slaveSlaveCallback ~slaveSlavePacking slaveSlaveChoices in let slaveSlaveSlave = make ~generator:(fun r -> slaveSlaveSlaveChoices (r#get "master") (r#get "slave") (r#get "slaveSlave")) ~msg:(Environments.make_string_env [("master",master#selected);("slave",master#slave#selected);("slaveSlave",master#slave#slave#selected)]) ~key:"slaveSlaveSlave" ~callback:slaveSlaveSlaveCallback ~packing:slaveSlaveSlavePacking in let _ = master#slave#slave#add_child slaveSlaveSlave in master (* Here you set the dependency. *) ;; (** {3 Simple tree constructor} *) (** {b Modelling a dependent tree of widgets: {v master / \ slave0 slave1 v} } *) (** Make a simple tree with 3 nodes: a root combo with two combos (dependent) children (which can be accessed with the handlers [master#slave0] and [master#slave1]). This function is in this API as an exemple. See the code in order to easily define your own comboTextTree. *) let fromListWithTwoSlaves ?(masterCallback:((choice->unit) option) = None) ?(masterPacking:((GObj.widget -> unit) option) = None) (masterChoices:choices) ?(slave0Callback:((choice->unit) option) = None) ?(slave0Packing:((GObj.widget -> unit) option) = None ) (slave0Choices: choice -> choices) ?(slave1Callback:((choice->unit) option) = None) ?(slave1Packing:((GObj.widget -> unit) option) = None ) (slave1Choices: choice -> choices) = let master = fromList ~key:"master" ~callback:masterCallback ~packing:masterPacking masterChoices in let slave0 = make ~generator:(fun r -> slave0Choices (r#get "master")) ~msg:(Environments.make_string_env [("master",master#selected)]) ~key:"slave0" ~callback:slave0Callback ~packing:slave0Packing in let slave1 = make ~generator:(fun r -> slave1Choices (r#get "master")) ~msg:(Environments.make_string_env [("master",master#selected)]) ~key:"slave1" ~callback:slave1Callback ~packing:slave1Packing in let _ = master#add_child slave0 in let _ = master#add_child slave1 in master ;; let fromListWithThreeSlaves ?(masterCallback:((choice->unit) option) = None) ?(masterPacking:((GObj.widget -> unit) option) = None) (masterChoices:choices) ?(slave0Callback:((choice->unit) option) = None) ?(slave0Packing:((GObj.widget -> unit) option) = None ) (slave0Choices: choice -> choices) ?(slave1Callback:((choice->unit) option) = None) ?(slave1Packing:((GObj.widget -> unit) option) = None ) (slave1Choices: choice -> choices) ?(slave2Callback:((choice->unit) option) = None) ?(slave2Packing:((GObj.widget -> unit) option) = None ) (slave2Choices: choice -> choices) = let master = fromList ~key:"master" ~callback:masterCallback ~packing:masterPacking masterChoices in let slave0 = make ~generator:(fun r -> slave0Choices (r#get "master")) ~msg:(Environments.make_string_env [("master",master#selected)]) ~key:"slave0" ~callback:slave0Callback ~packing:slave0Packing in let slave1 = make ~generator:(fun r -> slave1Choices (r#get "master")) ~msg:(Environments.make_string_env [("master",master#selected)]) ~key:"slave1" ~callback:slave1Callback ~packing:slave1Packing in let slave2 = make ~generator:(fun r -> slave2Choices (r#get "master")) ~msg:(Environments.make_string_env [("master",master#selected)]) ~key:"slave2" ~callback:slave2Callback ~packing:slave2Packing in let _ = master#add_child slave0 in let _ = master#add_child slave1 in let _ = master#add_child slave2 in master ;; end ;; (* Module ComboTextTree *) (* ********************************* * Class TextView Facilities for using GtkTextView * ********************************* *) class textview = fun ?(view:GText.view = GText.view ()) () -> let v = view in object (self) val view = v val buffer = v#buffer val mutable iter = v#buffer#get_iter_at_char 0 method view = view (** Append text with the optional list of tags. *) method append ?(tags=[]) x = buffer#insert ~iter:iter ~tag_names:tags x (** Append the image found in the given filename *) method append_image ?(scale:((int*int) option)=None) filename = begin let pixbuf = GdkPixbuf.from_file filename in let pixbuf = (match scale with | None -> pixbuf | Some (width,height) -> let scaled = GdkPixbuf.create ~has_alpha:true ~width ~height () in GdkPixbuf.scale ~dest:scaled ~width ~height ~interp:`BILINEAR pixbuf; scaled) in buffer#insert_pixbuf ~iter:iter ~pixbuf end (** Refresh the content applying tags. To use after all calls to append. *) method refresh () = begin let start,stop = buffer#bounds in buffer#apply_tag_by_name "word_wrap" ~start ~stop ; () end (** Delete the content of the buffer *) method delete () = begin let start,stop = buffer#bounds in buffer#delete ~start ~stop ; iter <- buffer#get_iter_at_char 0 end (** As append but first delete the old content *) method rewrite ?(tags=[]) x = self#delete () ; self#append ~tags x (** Call by initializer *) method private create_tags () = begin let stipple = Gdk.Bitmap.create_from_data 2 2 "\002\001" in buffer#create_tag ~name:"heading" [`WEIGHT `BOLD; `SIZE (15*Pango.scale)] => ignore ; buffer#create_tag ~name:"italic" [`STYLE `ITALIC] => ignore ; buffer#create_tag ~name:"bold" [`WEIGHT `BOLD] => ignore ; buffer#create_tag ~name:"big" [`SIZE 20] => ignore ; buffer#create_tag ~name:"xx-small" [`SCALE `XX_SMALL] => ignore ; buffer#create_tag ~name:"x-large" [`SCALE `X_LARGE] => ignore ; buffer#create_tag ~name:"monospace" [`FAMILY "monospace"] => ignore ; buffer#create_tag ~name:"blue_foreground" [`FOREGROUND "blue"] => ignore ; buffer#create_tag ~name:"red_background" [`BACKGROUND "red"] => ignore ; buffer#create_tag ~name:"background_stipple" [`BACKGROUND_STIPPLE stipple] => ignore ; buffer#create_tag ~name:"foreground_stipple" [`FOREGROUND_STIPPLE stipple] => ignore ; buffer#create_tag ~name:"big_gap_before_line" [`PIXELS_ABOVE_LINES 30] => ignore ; buffer#create_tag ~name:"big_gap_after_line" [`PIXELS_BELOW_LINES 30] => ignore ; buffer#create_tag ~name:"double_spaced_line" [`PIXELS_INSIDE_WRAP 10] => ignore ; buffer#create_tag ~name:"not_editable" [`EDITABLE false] => ignore ; buffer#create_tag ~name:"word_wrap" [`WRAP_MODE `WORD] => ignore ; buffer#create_tag ~name:"char_wrap" [`WRAP_MODE `CHAR] => ignore ; buffer#create_tag ~name:"no_wrap" [`WRAP_MODE `NONE] => ignore ; buffer#create_tag ~name:"center" [`JUSTIFICATION `CENTER] => ignore ; buffer#create_tag ~name:"right_justify" [`JUSTIFICATION `RIGHT] => ignore ; buffer#create_tag ~name:"wide_margins" [`LEFT_MARGIN 50; `RIGHT_MARGIN 50] => ignore ; buffer#create_tag ~name:"strikethrough" [`STRIKETHROUGH true] => ignore ; buffer#create_tag ~name:"underline" [`UNDERLINE `SINGLE] => ignore ; buffer#create_tag ~name:"double_underline" [`UNDERLINE `DOUBLE] => ignore ; buffer#create_tag ~name:"superscript" [`RISE (10*Pango.scale); `SIZE (8*Pango.scale)] => ignore ; buffer#create_tag ~name:"subscript" [`RISE (-10*Pango.scale); `SIZE (8*Pango.scale)] => ignore ; buffer#create_tag ~name:"rtl_quote"[`WRAP_MODE `WORD; `DIRECTION `RTL; `INDENT 30; `LEFT_MARGIN 20; `RIGHT_MARGIN 20] => ignore ; () end initializer self#create_tags () end;; (* class textview *) ocamlbricks-0.90+bzr456.orig/meta.ml.released0000644000175000017500000000140713175721006017771 0ustar lucaslucas(** Automatically generated meta-informations about the project and its building. *) (* This file is automatically generated; please don't edit it. *) let name = "ocamlbricks";; let version = "trunk";; let prefix = "/usr/local";; let prefix_install = "/usr/local";; let ocaml_version = "4.02.3";; let ocaml_libraryprefix = "/usr/lib/ocaml";; let libraryprefix = "/usr/lib/ocaml";; let configurationprefix = "/etc";; let localeprefix = "/usr/local/share/locale";; let documentationprefix = "/usr/local/share/doc";; let uname = "Linux 4.9.0-3-amd64 #1 SMP Debian 4.9.30-2+deb9u5 (2017-09-19) x86_64 GNU/Linux";; let build_date = "2017-10-30 23:04:53 +0100";; let revision = "456";; let source_date = "2017-10-30 20:38:00 +0100";; let source_date_utc_yy_mm_dd = "2017-10-30";; ocamlbricks-0.90+bzr456.orig/CONFIGURATION/0000755000175000017500000000000013175721005016732 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/CONFIGURATION/configuration_files.ml0000644000175000017500000006654513175721005023335 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2012 Jean-Vincent Loddo Copyright (C) 2008 2012 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Authors: * - Luca Saiu: configuration_files.ml * - Jean-Vincent Loddo: refactoring *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) type varname = string (** An alist is just a list of pairs: *) type 'a alist = (string * 'a) list;; (** For each variable bound in the shell environment echo its name and its value, one binding per line: *) let output_of_environment variables = let command_line = List.fold_left (fun string variable -> (* Print a line with: the variable name, a space, and its value, IF the variable is defined in the environment; otherwise don't print anything, and let the configuration file binding (if any) take precedence: *) Printf.sprintf "%s if test -n \"$%s\"; then echo %s \"$%s\"; fi; " string variable variable variable) "" variables in (* Printf.printf "The command line is\n%s\n" command_line; *) let (output, exit_code) = UnixExtra.run command_line in assert(exit_code = Unix.WEXITED 0); (* Printf.printf "The output is:\n-------------------------\n%s\n-------------------------\n" output; *) output;; (** Evaluate the given file, then 'echo' each variable name and its value, one variable per line: *) let output_of_file_name file_name variables = try let source_command_line = (* This is very important: dash does not support "source", you have to use the less readable, but more portable, ".": *) Printf.sprintf "set -e; (. %s 2> /dev/null &&" file_name in let command_line = List.fold_left (fun string variable -> (* Print a line with: the variable name, a space, and its value *) Printf.sprintf "%s echo %s $%s && " string variable variable) source_command_line variables in let command_line = command_line ^ " true) 2> /dev/null" in (* Printf.printf "The command line is %s\n" command_line; *) let (output, exit_code) = UnixExtra.run ~shell:"bash" command_line in if not (exit_code = Unix.WEXITED 0) then failwith ("Failed when source'ing the configuration file " ^ file_name) else begin (* Printf.printf "The output is:\n-------------------------\n%s\n-------------------------\n" output; *) output; end with _ -> begin (* Printf.printf "WARNING: could not source %s\n" file_name; *) ""; end;; (** Convert an output into a list of rows, where each row is a list of strings: first the variable name, then the value, possibly made of several tokens: *) let matrix_of_output output = StringExtra.Text.Matrix.of_string output;; (** Extract only the variable names from the matrix, disregarding values: *) let variables_of_matrix matrix = List.map (fun row -> match row with | variable :: _ -> variable | _ -> assert false) (* no line should be empty *) matrix;; (** Turn a matrix into an alist mapping each variable name into a value; each variable value (as a list of strings) is passed to the given function to obtain the value which is bound in the returned environment. Variables for which the given function fails are simply ignored: *) let alist_of_matrix row_to_element matrix = let result = ref [] in List.iter (fun row -> match row with | (variable :: values) -> (try result := (variable, (row_to_element values)) :: !result; with _ -> ()) | _ -> assert false) matrix; !result;; (** Turn a matrix into an alist mapping each variable name into a value; each variable value (as a single string, with token separated by a single space) is passed to the given function to obtain the value which is bound in the returned environment. Variables for which the given function fails are simply ignored: *) let scalar_alist_of_matrix string_to_element = alist_of_matrix (fun values -> string_to_element (String.concat " " values));; (** Turn a matrix into an alist mapping each variable name into the list of the tokens of its value: *) let list_alist_of_matrix = alist_of_matrix (fun values -> values);; (** Turn a matrix into an alist mapping each variable name into the string containing its value (tokens concatenated into a string, separated by single spaces): *) let string_alist_of_matrix = scalar_alist_of_matrix (fun string -> string);; (** Turn a matrix into an alist mapping each variable name with an integer value into the integer. Non-integer-valued variables are ignored: *) let int_alist_of_matrix = scalar_alist_of_matrix int_of_string;; (** Turn a matrix into an alist mapping each variable name with an float value into the float. Non-float-valued variables are ignored: *) let float_alist_of_matrix = scalar_alist_of_matrix float_of_string;; (** Turn a matrix into an alist mapping each variable name with an bool value into the bool. Non-bool-valued variables are ignored: *) let bool_alist_of_matrix = scalar_alist_of_matrix bool_of_string;; (** Turn a matrix into a "tuple of alists", which henceforth means an alist of strings, an alist of ints, an alist of floats, an alist of bools, and an alist of lists of strings; as usual, values of the "wrong" type are ignored: *) let alists_tuple_of_output output variables = let matrix = matrix_of_output output in let string_alist : (string * string) list = string_alist_of_matrix matrix in let int_alist : (string * int) list = int_alist_of_matrix matrix in let float_alist : (string * float) list = float_alist_of_matrix matrix in let bool_alist : (string * bool) list = bool_alist_of_matrix matrix in let list_alist : (string * (string list)) list = list_alist_of_matrix matrix in (* --- *) (string_alist, int_alist, float_alist, bool_alist, list_alist) ;; (** Turn a *file* into a tuple of alists: *) let alists_tuple_of_file (file_name) (variables) = let output = output_of_file_name file_name variables in let (ts, ti, tf, tb, tl) = alists_tuple_of_output output variables in (* Inject now the information about the source (file_name) of the binding: *) let inj xys = List.map (fun (x,y) -> (x, (y, `Filename file_name))) xys in ((inj ts), (inj ti), (inj tf), (inj tb), (inj tl)) ;; (** Merge the two given alist groups; the latest one takes precedence: *) let merge_alists xss yss = let (string_xs, int_xs, float_xs, bool_xs, list_xs) = xss in let (string_ys, int_ys, float_ys, bool_ys, list_ys) = yss in (string_xs @ string_ys, int_xs @ int_ys, float_xs @ float_ys, bool_xs @ bool_ys, list_xs @ list_ys) ;; type source = [ `Filename of string | `Environment ] (** Make a configuration object from a list of file name or a software name; in the latter case the configuration files have "reasonable" default names; {b Example}: {[let q = new configuration ~file_names:["~luca/working/ocamlbricks/MYSETTINGS"; "~luca/working/ocamlbricks/MYSETTINGS2"] ~software_name:"marionnet" ~variables:["ZZZ"; "fortytwo";] ();; Printf.printf ">%s<\n" (q#string "ZZZ");; Printf.printf ">%i<\n" (q#int "fortytwo");; Printf.printf ">%f<\n" (q#float "fortytwo");; ]} *) class configuration = fun ?software_name ?file_names ~variables ?(dont_read_environment:unit option) () -> let read_environment = (dont_read_environment = None) in let file_names = match file_names, software_name with | None, None -> failwith "either ~software_name or ~file_names should be passed" | (Some file_names), None -> file_names | None, (Some software_name) -> [ Printf.sprintf "/etc/%s/%s.conf" software_name software_name; Printf.sprintf "~/.%s/%s.conf" software_name software_name ] | (Some _), (Some _) -> failwith "you should pass exactly one of ~software_name and ~file_names" in object(self) (* Associative containers used for efficient access, after initialization: *) val string_hashmap = new Hashmap.hashmap (); val int_hashmap = new Hashmap.hashmap (); val float_hashmap = new Hashmap.hashmap (); val bool_hashmap = new Hashmap.hashmap (); val list_hashmap = new Hashmap.hashmap (); initializer begin (* First execute all configuration files in the correct order, and merge the bindings: *) let alists = List.fold_left (fun accumulator file_name -> merge_alists accumulator (alists_tuple_of_file file_name variables)) ([], [], [], [], []) file_names in (* If we also want to access the shell environment, then look it up, and give it precedence over configuration files: *) let (string_alist, int_alist, float_alist, bool_alist, list_alist) = if read_environment then let environment_output = output_of_environment variables in let (ts, ti, tf, tb, tl) = alists_tuple_of_output environment_output variables in (* Inject now the information about the source (the environment) of the binding: *) let inj xys = List.map (fun (x,y) -> (x, (y, `Environment))) xys in let alists_tuple_env = ((inj ts), (inj ti), (inj tf), (inj tb), (inj tl)) in merge_alists alists (alists_tuple_env) else alists in (* Finally convert the bindings from alists into hashes, for efficient access: *) string_hashmap#add_list string_alist; int_hashmap#add_list int_alist; float_hashmap#add_list float_alist; bool_hashmap#add_list bool_alist; list_hashmap#add_list list_alist; end (* The list of variable is redefined now as set: *) val expected_variables = SetExtra.String_set.of_list variables method check_expected_variable_or_raise_invalid_arg x = if (SetExtra.String_set.mem x expected_variables) then () else invalid_arg (Printf.sprintf "Configuration_files: Unexpected variable name `%s'" x) method expected_variable x = (SetExtra.String_set.mem x expected_variables) (** Lookup a variable of the type [string]. *) method string x = fst (string_hashmap#lookup x) method string_with_source x : string * source = string_hashmap#lookup x (** Lookup a variable of the type [int]. *) method int x = fst (int_hashmap#lookup x) method int_with_source x : int * source = int_hashmap#lookup x (** Lookup a variable of the type [float]. *) method float x = fst (float_hashmap#lookup x) method float_with_source x : float * source = float_hashmap#lookup x (** Lookup a variable of the type [bool]. *) method bool x = fst (bool_hashmap#lookup x) method bool_with_source x : bool * source = bool_hashmap#lookup x (** Lookup a variable of the type [string list]. *) method list x = fst (list_hashmap#lookup x) method list_with_source x : string list * source = list_hashmap#lookup x end;; (* class *) type t = configuration let make = new configuration module Polymorphic_functions = struct let extract_variable_or : ?k:('a -> 'a) -> (* An optional continuation *) ?log_printf:(string -> unit) Log_builder.printf -> (* An optional Log.printf *) ?ignore_undeclared:unit -> (* Do not fail, just warning if `log_printf' is provided *) ?unsuitable_value:('a -> bool) -> (* Filter unsuitable values *) to_string:('a -> string) -> (* String conversion for logging messages *) default:'a -> (* The default value, if the variable is undeclared or its value unsuitable *) mthd:(varname -> 'a) -> (* The method of an instance of the class configuration. For instance `configuration#float' *) varname -> (* The name of the variable *) t -> 'a = fun ?(k:('a -> 'a) option) ?(log_printf:((string->unit) Log_builder.printf) option) ?ignore_undeclared ?(unsuitable_value=(fun y -> false)) (* values are suitable by default *) ~(to_string:'a -> string) ~(default:'a) (* The method of an instance of the class configuration. For instance `configuration#float': *) ~(mthd:varname -> 'a) (varname:string) (t:t) -> let () = if ignore_undeclared = None then t#check_expected_variable_or_raise_invalid_arg varname else () in let log_printf = match log_printf with | None -> fun ?v ?force ?banner _ _ -> () | Some printf -> printf in let fallback e x = if (t#expected_variable x) then () else log_printf "Warning: %s not declared.\n" x in let use_default () = log_printf " - using default \"%s\"\n" (to_string default); default in let use_found_value y = log_printf " - found value \"%s\"\n" (to_string y); y in let result = log_printf "Searching for variable %s:\n" varname; match Option.apply_or_catch ~fallback mthd varname with | None -> use_default () | Some y when (unsuitable_value y) -> use_default () | Some y -> use_found_value y in (* Launch the continuation on the result: *) match k with None -> result | Some f -> (f result) ;; let get_variable : ?k:('a -> 'a option) -> (* An optional continuation (called with Option.bind) *) ?log_printf:(string -> unit) Log_builder.printf -> (* An optional Log.printf *) ?ignore_undeclared:unit -> (* Do not fail, just warning if `log_printf' is provided *) ?unsuitable_value:('a -> bool) -> (* Filter unsuitable values *) to_string:('a -> string) -> (* String conversion for logging messages *) mthd:(varname -> 'a) -> (* The method of an instance of the class configuration. For instance `configuration#float' *) varname -> (* The name of the variable *) t -> 'a option = fun ?(k:('a -> 'a option) option) ?(log_printf:((string->unit) Log_builder.printf) option) ?ignore_undeclared ?(unsuitable_value=(fun y -> false)) (* values are suitable by default *) ~(to_string:'a -> string) ~(mthd:varname -> 'a) varname t -> let () = if ignore_undeclared = None then t#check_expected_variable_or_raise_invalid_arg varname else () in let log_printf = match log_printf with | None -> fun ?v ?force ?banner _ _ -> () | Some printf -> printf in let fallback e x = if (t#expected_variable x) then () else log_printf "Warning: %s not declared.\n" x in let use_found_value y = log_printf " - found value \"%s\"\n" (to_string y); y in let result = log_printf "Searching for variable %s:\n" varname; match Option.apply_or_catch ~fallback mthd varname with | None -> None | Some y when (unsuitable_value y) -> None | Some y -> Some (use_found_value y) in (* Launch the continuation on the result: *) match k with None -> result | Some f -> Option.bind result f ;; end (* module Polymorphic_functions *) (* ============================================ Now starts the user interface section... =========================================== *) (** The type of functions looking in the structure for a variable and returning an optional result: *) type 'a get_variable = ?k:('a -> 'a option) -> (* An optional continuation (called with Option.bind) *) ?ignore_undeclared:unit -> (* Do not fail when undeclared *) ?unsuitable_value:('a -> bool) -> (* Filter unsuitable values *) varname -> (* The name of the variable *) t -> 'a option (** The type of functions looking in the structure for a variable and returning the value found or a default: *) type 'a extract_variable_or = ?k:('a -> 'a) -> (* An optional continuation *) ?ignore_undeclared:unit -> (* Do not fail when undeclared *) ?unsuitable_value:('a -> bool) -> (* Filter unsuitable values *) default:'a -> (* The default value, if the variable is undeclared or its value unsuitable *) varname -> (* The name of the variable *) t -> 'a let get_bool_variable : bool get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(string_of_bool) ~mthd:(t#bool) varname t let get_float_variable : float get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(string_of_float) ~mthd:(t#float) varname t let get_int_variable : int get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(string_of_int) ~mthd:(t#int) varname t let add_constraint_not_empty_string ?unsuitable_value () : (string -> bool) = let result = match unsuitable_value with | None -> ((=)"") | Some f -> (fun y -> (y="") || (f y)) in result let get_string_variable : string get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> (* Empty strings are not considered as a result (=> None): *) let f = add_constraint_not_empty_string ?unsuitable_value () in Polymorphic_functions.get_variable ?k ?ignore_undeclared ~unsuitable_value:f ~to_string:(fun x -> x) ~mthd:(t#string) varname t let get_string_list_variable : (string list) get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(String.concat " ") ~mthd:(t#list) varname t let extract_bool_variable_or : bool extract_variable_or = fun ?k ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~to_string:(string_of_bool) ~default ~mthd:(t#bool) varname t let extract_float_variable_or : float extract_variable_or = fun ?k ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~to_string:(string_of_float) ~default ~mthd:(t#float) varname t let extract_int_variable_or : int extract_variable_or = fun ?k ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~to_string:(string_of_int) ~default ~mthd:(t#int) varname t let extract_string_variable_or : string extract_variable_or = fun ?k ?ignore_undeclared ?unsuitable_value ~default varname t -> (* Empty strings are not considered as a result (=> default): *) let f = add_constraint_not_empty_string ?unsuitable_value () in Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ~unsuitable_value:f ~to_string:(fun x->x) ~default ~mthd:(t#string) varname t let extract_string_list_variable_or : (string list) extract_variable_or = fun ?k ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~to_string:(String.concat " ") ~default ~mthd:(t#list) varname t module With_source = struct let string_of_source = function | `Environment -> "" | `Filename f -> f let get_bool_variable : (bool * source) get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(fun (x,s) -> Printf.sprintf "(%b, %s)" x (string_of_source s)) ~mthd:(t#bool_with_source) varname t let get_float_variable : (float * source) get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(fun (x,s) -> Printf.sprintf "(%F, %s)" x (string_of_source s)) ~mthd:(t#float_with_source) varname t let get_int_variable : (int * source) get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(fun (x,s) -> Printf.sprintf "(%d, %s)" x (string_of_source s)) ~mthd:(t#int_with_source) varname t let add_constraint_not_empty_string ?unsuitable_value () : (string * source -> bool) = let result = match unsuitable_value with | None -> (fun (x,s) -> x = "") | Some f -> (fun (y,s) -> (y="") || (f (y,s))) in result let get_string_variable : (string * source) get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> (* Empty strings are not considered as a result (=> None): *) let f = add_constraint_not_empty_string ?unsuitable_value () in Polymorphic_functions.get_variable ?k ?ignore_undeclared ~unsuitable_value:f ~to_string:(fun (x,s) -> Printf.sprintf "(%s, %s)" x (string_of_source s)) ~mthd:(t#string_with_source) varname t let get_string_list_variable : ((string list) * source) get_variable = fun ?k ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~to_string:(fun (x,s) -> Printf.sprintf "([%s], %s)" (String.concat "; " x) (string_of_source s)) ~mthd:(t#list_with_source) varname t end (* Versions with logging features: *) module Logging = struct (** The type of (logged) functions looking in the structure for a variable and returning an optional result: *) type 'a get_variable = ?k:('a -> 'a option) -> (* An optional continuation (called with Option.bind) *) ?log_printf:(string -> unit) Log_builder.printf -> (* An optional Log.printf *) ?ignore_undeclared:unit -> (* Do not fail, just warning (supposing that `log_printf' has been provided) *) ?unsuitable_value:('a -> bool) -> (* Filter unsuitable values *) varname -> (* The name of the variable *) t -> 'a option (** The type of (logged) functions looking in the structure for a variable and returning the value found or a default: *) type 'a extract_variable_or = ?k:('a -> 'a) -> (* An optional continuation *) ?log_printf:(string -> unit) Log_builder.printf -> (* An optional Log.printf *) ?ignore_undeclared:unit -> (* Do not fail, just warning (supposing that `log_printf' has been provided) *) ?unsuitable_value:('a -> bool) -> (* Filter unsuitable values *) default:'a -> (* The default value, if the variable is undeclared or its value unsuitable *) varname -> (* The name of the variable *) t -> 'a let get_bool_variable : bool get_variable = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(string_of_bool) ~mthd:(t#bool) varname t let get_float_variable : float get_variable = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(string_of_float) ~mthd:(t#float) varname t let get_int_variable : int get_variable = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(string_of_int) ~mthd:(t#int) varname t let get_string_variable : string get_variable = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value varname t -> (* Empty strings are not considered as a result (=> default): *) let f = add_constraint_not_empty_string ?unsuitable_value () in Polymorphic_functions.get_variable ?k ?ignore_undeclared ~unsuitable_value:f ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(fun x -> x) ~mthd:(t#string) varname t let get_string_list_variable : (string list) get_variable = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value varname t -> Polymorphic_functions.get_variable ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(String.concat " ") ~mthd:(t#list) varname t let extract_bool_variable_or : bool extract_variable_or = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(string_of_bool) ~default ~mthd:(t#bool) varname t let extract_float_variable_or : float extract_variable_or = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(string_of_float) ~default ~mthd:(t#float) varname t let extract_int_variable_or : int extract_variable_or = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(string_of_int) ~default ~mthd:(t#int) varname t let extract_string_variable_or : string extract_variable_or = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value ~default varname t -> (* Empty strings are not considered as a result (=> default): *) let f = add_constraint_not_empty_string ?unsuitable_value () in Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ~unsuitable_value:f ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(fun x->x) ~default ~mthd:(t#string) varname t let extract_string_list_variable_or : (string list) extract_variable_or = fun ?k ?log_printf ?ignore_undeclared ?unsuitable_value ~default varname t -> Polymorphic_functions.extract_variable_or ?k ?ignore_undeclared ?unsuitable_value ~log_printf:(Option.extract_or log_printf Ocamlbricks_log.printf1) ~to_string:(String.concat " ") ~default ~mthd:(t#list) varname t end (* Logging *) ocamlbricks-0.90+bzr456.orig/CONFIGURATION/configuration_files.mli0000644000175000017500000001613613175721005023475 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2012 Jean-Vincent Loddo Copyright (C) 2008 2012 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Simple implementation of application-wise configuration files, implemented as shell scripts. Configuration files are looked for (by default) in "standard" places like /etc, the user's home directory and the shell environment. There is a priority: - System-wise files in /etc - User's files in ~ - The shell environment at application startup time. *) (** {b Examples}: {[ let t = Configuration_files.make ~file_names:["/etc/os-release"] ~variables:["NAME";"VERSION";"ID"] () ;; val t : Configuration_files.t = let name = Configuration_files.get_string_variable "NAME" t ;; val name : string option = Some "Ubuntu" let version = Configuration_files.extract_string_variable_or ~default:"none" "VERSION" t ;; val version : string = "12.04.1 LTS, Precise Pangolin" let version = Configuration_files.extract_string_list_variable_or ~default:[] "VERSION" t ;; val version : string list = ["12.04.1"; "LTS,"; "Precise"; "Pangolin"] let version = Configuration_files.Logging.extract_string_list_variable_or ~default:[] "VERSION" t ;; [18821.0]: Searching for variable VERSION: [18821.0]: - found value "12.04.1 LTS, Precise Pangolin" val version : string list = ["12.04.1"; "LTS,"; "Precise"; "Pangolin"] let foobar = Configuration_files.Logging.extract_string_list_variable_or ~default:[] "FOOBAR" t ;; Exception: Invalid_argument "Configuration_files: Unexpected variable name `FOOBAR'". let foobar = Configuration_files.Logging.extract_string_list_variable_or ~ignore_undeclared:() ~default:[] "FOOBAR" t ;; [18407.0]: Searching for variable FOOBAR: [18407.0]: Warning: FOOBAR not declared. [18407.0]: - using default "" val foobar : string list = [] ]} *) (** The abstract data type representing a configuration, make by reading file(s). *) type t type varname = string val make : ?software_name:string -> ?file_names:string list -> variables:varname list -> ?dont_read_environment:unit -> unit -> t (** The type of functions looking in the structure for a variable and returning an optional result: *) type 'a get_variable = ?k:('a -> 'a option) -> (** An optional continuation (called with Option.bind) *) ?ignore_undeclared:unit -> (** Do not fail when undeclared *) ?unsuitable_value:('a -> bool) -> (** Filter unsuitable values *) varname -> (** The name of the variable *) t -> 'a option (** The type of functions looking in the structure for a variable and returning the value found or a default: *) type 'a extract_variable_or = ?k:('a -> 'a) -> (** An optional continuation *) ?ignore_undeclared:unit -> (** Do not fail when undeclared *) ?unsuitable_value:('a -> bool) -> (** Filter unsuitable values *) default:'a -> (** The default value, if the variable is undeclared or its value unsuitable *) varname -> (** The name of the variable *) t -> 'a val get_bool_variable : bool get_variable val get_float_variable : float get_variable val get_int_variable : int get_variable val get_string_variable : string get_variable val get_string_list_variable : (string list) get_variable val extract_bool_variable_or : bool extract_variable_or val extract_float_variable_or : float extract_variable_or val extract_int_variable_or : int extract_variable_or val extract_string_variable_or : string extract_variable_or val extract_string_list_variable_or : (string list) extract_variable_or (* With source: *) type source = [ `Filename of string | `Environment ] (* --- *) module With_source : sig val get_bool_variable : (bool * source) get_variable val get_float_variable : (float * source) get_variable val get_int_variable : (int * source) get_variable val get_string_variable : (string * source) get_variable val get_string_list_variable : ((string list) * source) get_variable end (** Versions with logging features: *) module Logging : sig (** The type of (logged) functions looking in the structure for a variable and returning an optional result: *) type 'a get_variable = ?k:('a -> 'a option) -> (** An optional continuation (called with Option.bind) *) ?log_printf:(string -> unit) Log_builder.printf -> (** An optional Log.printf *) ?ignore_undeclared:unit -> (** Do not fail, just warning if `log_printf' is provided *) ?unsuitable_value:('a -> bool) -> (** Filter unsuitable values *) varname -> (** The name of the variable *) t -> 'a option (** The type of (logged) functions looking in the structure for a variable and returning the value found or a default: *) type 'a extract_variable_or = ?k:('a -> 'a) -> (** An optional continuation *) ?log_printf:(string -> unit) Log_builder.printf -> (** An optional Log.printf *) ?ignore_undeclared:unit -> (** Do not fail, just warning if `log_printf' is provided *) ?unsuitable_value:('a -> bool) -> (** Filter unsuitable values *) default:'a -> (** The default value, if the variable is undeclared or its value unsuitable *) varname -> (** The name of the variable *) t -> 'a val get_bool_variable : bool get_variable val get_float_variable : float get_variable val get_int_variable : int get_variable val get_string_variable : string get_variable val get_string_list_variable : (string list) get_variable val extract_bool_variable_or : bool extract_variable_or val extract_float_variable_or : float extract_variable_or val extract_int_variable_or : int extract_variable_or val extract_string_variable_or : string extract_variable_or val extract_string_list_variable_or : (string list) extract_variable_or end (* Logging *) ocamlbricks-0.90+bzr456.orig/meta.ml0000644000175000017500000000140713175721006016206 0ustar lucaslucas(** Automatically generated meta-informations about the project and its building. *) (* This file is automatically generated; please don't edit it. *) let name = "ocamlbricks";; let version = "trunk";; let prefix = "/usr/local";; let prefix_install = "/usr/local";; let ocaml_version = "4.02.3";; let ocaml_libraryprefix = "/usr/lib/ocaml";; let libraryprefix = "/usr/lib/ocaml";; let configurationprefix = "/etc";; let localeprefix = "/usr/local/share/locale";; let documentationprefix = "/usr/local/share/doc";; let uname = "Linux 4.9.0-3-amd64 #1 SMP Debian 4.9.30-2+deb9u5 (2017-09-19) x86_64 GNU/Linux";; let build_date = "2017-10-30 23:04:53 +0100";; let revision = "456";; let source_date = "2017-10-30 20:38:00 +0100";; let source_date_utc_yy_mm_dd = "2017-10-30";; ocamlbricks-0.90+bzr456.orig/INSTALL0000644000175000017500000001642213175721005015761 0ustar lucaslucasThis file is part of our build system for OCaml projects. Copyright (C) 2008 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . These are generic installation instructions, applyable to all the OCaml projects released by Jean-Vincent Loddo and Luca Saiu. Requirements ============ GNU Make and OCamlBuild are always required *for compilation*. Please also see the file "REQUIREMENTS" for the specific build-time and runtime requirements of this particular project. Configuration ============= Configuration is currently manual, but very easy; you need to edit the CONFIGME text file, which is actually a bash script. CONFIGME contains three distinct sections: you can setup: * Configuration time parameters, for example enabling or disabling some features. * Installation parametetrs, for example installation paths. * Default settings which will be copied into /etc/PROJECTNAME; such default settings are overridable by each user by creating a ~/.PROJECTNAME file. A "configure" script is also provided just in order to make the feel of the configuration more "standard", but the script is currently limited to printing a message asking the user to edit CONFIGME. Compilation =========== You can build all the default targets by simply running GNU make, with no parameters; this means just typing make on GNU systems such as GNU/Linux, and possibly gmake on other systems such as BSD. From now on we are going to assume that GNU Make is installed as "make". Programs and libraries are always created in the "_build/" subdirectory. Make should print "Success" at the end of the compilation process if all goes well. Some other useful targets are "programs", "libraries" and "data", which build only programs, only libraries, or only machine-generated data, respectively. Potential parallelism in building is currently not exploited. Installation and uninstallation =============================== Installation and uninstallation are very easy, if you have correctly setup paths in the configuration phase. Installation ------------ In order to install the package on your system (in the pathnames you have specified at configuration time) just build the target "install". On GNU systems this means typing make install . Note that, at least as of now, only a single version at the time can be installed for each package. Uninstallation -------------- If you have already installed your package but you want to remove it, then build the target "uninstall" by typing make uninstall . Note that you need to have the same CONFIGME you have used when you configured the package for installation: CONFIGME contains the path information, which is obviously required also at uninstallation time. OCamlDoc source documentation ============================= You can generate OCamlDoc source documentation in HTML format by building the target "ocamldoc". Note that the OCamlDoc settings are not the default ones supported by OCamlBuild, and in particular they include module implementations, and not only their signatures. Documentation is generated in the directory _build/PROJECTNAME.docdir/ . Making tarballs =============== The build system includes some features to generate source and binary tarballs in a very convenient way; this is particularly useful when you have downloaded a snapshot of the package from a revision-control system such as CVS or darcs, and you want to distribute an easy-to-use tarball to other users. Source tarballs --------------- You can generate a source gzipped tarball with a suitable name is by building the "dist" target: make dist Notice that the tarball is actually generated in the "_build/" directory. Binary tarballs --------------- Binary tarballs don't contain sources, but are installable and uninstallable by building the appropriate Make target after decompression. Their file name also includes the operating system and hardware architecture name. You can generate a binary tarball by building the "dist-binary" target: make dist-binary The tarball is generated in "_build/". An important reminder about binary tarballs ------------------------------------------- There shouldn't be any need to remind you of this, but just to play it safe: remember that the GPL requires you to *ALSO DISTRIBUTE SOURCES* if you distribute binaries. Hence, if you make a binary tarball available, then you should also publish a source tarball in the same place (this is the simplest alternative; another possibility is to provide a *written* offer, valid for at least three years, to also supply the sources at no additional charge; see the GPL text for all the details). How this system works ===================== This system uses a combination of GNU Make and OCamlBuild to create targets: OCamlBuild is only used for automatic dependency tracking, which is by itself a quite complex job. Its configuration is customized by a _tags file and a plugin, myocamlbuild.ml: *both* files are automatically generated from the information present int META (which includes the package name, version string, and the like), from the CONFIGME file, and from the results of build-time analyes of the source directories. We conceptually always work on a *flat directory structure*, in which any file can refer any other -- unless there are circular dependencies: this is a current, quite unfortunate limitation of OCaml. Notice that different Makefiles for each directory are *NOT* required, nor supported. See the section "An alternative Approach to subdirectories" in the AutoMake manual for justifications of this idea. The build system logic is independent from the particular project and is implemented in the main "Makefile". Despite such Makefile being quite readable and well-commented, its behavior is not completely trivial, requiring some minor GNU Make and Bash magic. For each project a Makefile.local file (included by the main Makefile) defines some variables such as PROGRAMS and LIBRARIES, and optionally provides rules to build automatically generated sources. Makefile.local can extend the behavior of most targets by defining "-local" targets. For each library provided by the project (of course they may be zero) an ".mllib" file is provided listing the OCaml modules (*modules*, not file names) to be included. When generation of OCamlDoc source documentation is desired, a "PROJECTNAME.odocl" file is provided, again containing a list of OCaml modules. Please see the Makefile for more details. Bug reporting, suggestions and discussions ========================================== Bugs in this build system should be reported by using the Savane interface at https://savane.marionnet.org/projects/marionnet or to the public mailing list marionnet-dev@marionnet.org . The mailing list can also be used for general discussions about the build system. We welcome feedback. ocamlbricks-0.90+bzr456.orig/Makefile.local.for_copies0000644000175000017500000001525613175721005021614 0ustar lucaslucas# This -*- makefile -*- is part of our reusable OCaml BRICKS library # Copyright (C) 2008, 2011 Luca Saiu # Copyright (C) 2008, 2010, 2011 Jean-Vincent Loddo # Copyright (C) 2008, 2010, 2011 Université Paris 13 # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # Set this variable to "-verbose 0" for more details OCAMLBUILD_OPTIONS=-quiet COMPILE_OPTIONS += -g -thread DIRECTORIES_TO_INCLUDE = threads lablgtk2 camlp4 LIBRARIES_TO_LINK = str unix threads lablgtk # NATIVE_PROGRAMS += mutexExtra_test.native # BYTE_PROGRAMS += mutexExtra_test.byte NATIVE_LIBRARY_NAME = ocamlbricks.cmxa BYTE_LIBRARY_NAME = ocamlbricks.cma NATIVE_LIBRARIES = $(shell \ if which ocamlopt.opt &>/dev/null || which ocamlopt &>/dev/null;\ then echo $(NATIVE_LIBRARY_NAME); fi) BYTE_LIBRARIES = $(shell \ if which ocamlc.opt &>/dev/null || which ocamlc &>/dev/null;\ then echo $(BYTE_LIBRARY_NAME); fi) # Empty for OCaml 3.x.y series, set to "-DOCAML4_OR_LATER" for 4.x.y or later: OCAML4_OR_LATER=$(shell if grep -q "^[4-9]" <<<"$(OCAML_VERSION)"; then echo "-DOCAML4_OR_LATER"; fi) # Transmit the information about the compiler version in order to # activate conditional compilation: PP_OPTION = camlp4of $(OCAML4_OR_LATER) GETTEXT=GETTEXT C_OBJECTS_TO_LINK = gettext-c-wrapper does-process-exist-c-wrapper waitpid-c-wrapper OTHER_LIBRARY_FILES_TO_INSTALL = _build/{gettext-c-wrapper.o,does-process-exist-c-wrapper.o,gettext_extract_pot_p4.cmo,waitpid-c-wrapper.o,include_type_definitions_p4.cmo,include_as_string_p4.cmo,where_p4.cmo,option_extract_p4.cmo,raise_p4.cmo,log_module_loading_p4.cmo} MANUALLY_PRE_COPY_IN_build = \ GETTEXT/gettext_extract_pot_p4.ml{,i} \ GETTEXT/gettext-c-wrapper.c \ EXTRA/does-process-exist-c-wrapper.c \ EXTRA/waitpid-c-wrapper.c \ CAMLP4/include_type_definitions_p4.ml{,i} \ CAMLP4/include_as_string_p4.ml{,i} \ CAMLP4/where_p4.ml{,i} \ CAMLP4/option_extract_p4.ml{,i} \ CAMLP4/common_tools_for_preprocessors.ml{,i} \ CAMLP4/raise_p4.ml{,i} \ CAMLP4/log_module_loading_p4.ml{,i} MANUALLY_PRE_MAKE_IN_build = \ gettext_extract_pot_p4.cm{i,o} \ include_type_definitions_p4.cm{i,o} \ include_as_string_p4.cm{i,o} \ where_p4.cm{i,o} \ option_extract_p4.cm{i,o} \ raise_p4.cm{i,o} \ log_module_loading_p4.cm{i,o} \ libocamlbricks_stubs.a main-local: meta_ocamlbricks.ml meta_ocamlbricks.ml: meta.ml cp $< meta_ocamlbricks.ml EXCLUDE_FROM_EDITING=meta_ocamlbricks.ml # include_type_definitions_p4 _build/include_type_definitions_p4.cmi: CAMLP4/include_type_definitions_p4.mli ocamlc -c -I +camlp4 -pp camlp4of -o $@ $< _build/include_type_definitions_p4.cmo: CAMLP4/include_type_definitions_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< # include_as_string_p4 _build/include_as_string_p4.cmi: CAMLP4/include_as_string_p4.mli ocamlc -c -I +camlp4 -pp camlp4of -o $@ $< _build/include_as_string_p4.cmo: CAMLP4/include_as_string_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/where_p4.cmi: CAMLP4/where_p4.mli ocamlc -c -I +camlp4 -pp camlp4of -o $@ $< _build/where_p4.cmo: CAMLP4/where_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/option_extract_p4.cmi: CAMLP4/option_extract_p4.mli ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/option_extract_p4.cmo: CAMLP4/option_extract_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/raise_p4.cmi: CAMLP4/raise_p4.mli ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/raise_p4.cmo: CAMLP4/raise_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/log_module_loading_p4.cmi: CAMLP4/log_module_loading_p4.mli ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< _build/log_module_loading_p4.cmo: CAMLP4/log_module_loading_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of -o $@ $< # gettext_extract_pot_p4 _build/gettext_extract_pot_p4.cmi: $(GETTEXT)/gettext_extract_pot_p4.mli ocamlc -c -I +camlp4 -pp camlp4of camlp4lib.cma -o $@ $< _build/gettext_extract_pot_p4.cmo: $(GETTEXT)/gettext_extract_pot_p4.ml ocamlc -c -I +camlp4 -I _build/ -pp camlp4of camlp4lib.cma -o $@ $< _build/libocamlbricks_stubs.a: $(GETTEXT)/gettext-c-wrapper.c EXTRA/does-process-exist-c-wrapper.c EXTRA/waitpid-c-wrapper.c @(mkdir _build &> /dev/null || true); \ cd _build; \ ocamlc -c -verbose $(GETTEXT)/gettext-c-wrapper.c; \ ocamlc -c -verbose EXTRA/does-process-exist-c-wrapper.c; \ ocamlc -c -verbose EXTRA/waitpid-c-wrapper.c; \ ocamlmklib -verbose -oc ocamlbricks_stubs gettext-c-wrapper.o does-process-exist-c-wrapper.o waitpid-c-wrapper.o MANUALLY_POST_MAKE_IN_build= rebuild-library-with-linkall install-all-files-in-a-single-local-directory # idempotent _build/rebuild-library-with-linkall: @chmod +x Makefile.d/ocamlmklib_wrapper.sh @Makefile.d/ocamlmklib_wrapper.sh $(C_OBJECTS_TO_LINK) FLATTENED_DIRECTORY=_build/_build.flattened _build/install-all-files-in-a-single-local-directory: @mkdir -p $(FLATTENED_DIRECTORY); @find _build/ -path $(FLATTENED_DIRECTORY) -prune -o -type f -exec cp -fl {} $(FLATTENED_DIRECTORY)/ \; @echo "Success: ocamlbricks was rebuilt linking all stubs and was installed for marionnet in a local directory ($(FLATTENED_DIRECTORY))."; preprocessors: _build/gettext_extract_pot_p4.cmo rebuilding: $(MAKE) _build/rebuild-library-with-linkall # install-libraries-local: _build/rebuild-library-with-linkall preprocessors install-libraries-local: rebuilding preprocessors # Remove the automatically-generated documentation on clean: clean-local: @rm -rf doc/html @rm -f meta_ocamlbrics.ml _build/meta_ocamlbrics.ml @rm -rf _build/does_process_exist.o @rm -rf _build/waitpid-c-wrapper.o compile_for_testing: @if grep -q "DDOCUMENTATION_OR_DEBUGGING" $(LOGFILE); then echo "Fine, already compiled for testing."; else make clean; fi; \ make PP_OPTION="$(PP_OPTION) -DDOCUMENTATION_OR_DEBUGGING" # Test without installation LIBRARY_TO_TEST=_build/ocamlbricks.cma test: compile_for_testing rebuilding @chmod +x Makefile.d/test_with.sh @Makefile.d/test_with.sh "ocaml" # Test without installation with the utop toplevel test_with_utop: compile_for_testing rebuilding @chmod +x Makefile.d/test_with.sh @Makefile.d/test_with.sh "utop" ocamlbricks-0.90+bzr456.orig/meta_ocamlbricks.mli0000644000175000017500000000052313175721005020725 0ustar lucaslucasval name : string val version : string val prefix : string val ocaml_libraryprefix : string val libraryprefix : string val configurationprefix : string val localeprefix : string val documentationprefix : string val uname : string val build_date : string val revision : string val source_date : string val source_date_utc_yy_mm_dd : string ocamlbricks-0.90+bzr456.orig/NEWS0000644000175000017500000000136713175721005015431 0ustar lucaslucasThis file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2008 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . [To do: fill this.] ocamlbricks-0.90+bzr456.orig/CONFIGME0000644000175000017500000001030313175721005016032 0ustar lucaslucas# This -*- sh -*- script is part of our reusable OCaml BRICKS library # Copyright (C) 2008 2011 Luca Saiu # Copyright (C) 2008 2012 2016 Jean-Vincent Loddo # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . ########################################################################### ########################################################################### # This file should be hand-edited at configuration time, before compiling. ########################################################################### ########################################################################### ########################################################################### # Section 1: Configuration choices ########################################################################### # (this section is empty for ocamlbricks). ########################################################################### # Section 2: Installation setup: prefixes, and the like ########################################################################### # Run-time prefix, where resources will be really installed and available # when the software will be launched. Examples are /usr or /usr/local. # *No* trailing slash should be included. prefix=/usr/local # Prefix for temporary or final installation; you should probably keep the # default setting, which is ${prefix}. This variable has been introduced to # deal with some specific packaging methods (Archlinux). # *No* trailing slash should be included. prefix_install=${prefix} # Prefix for host-wide configuration files; you should probably keep the # default setting: configurationprefix=/etc # Prefix for the locale files (at run-time) localeprefix=${prefix}/share/locale # Prefix for documentation files; you should probably keep the # default setting: documentationprefix=${prefix}/share/doc # Version of OCaml we are using to compile the project: ocaml_version=$(ocamlc -version || exit -1) # Location of the standard Ocaml libraries required to compile # and link the project. # *No* trailing slash should be included. ocaml_libraryprefix=$(ocamlc -where || exit -1) # #ocaml_libraryprefix=/mystrangepath # Installation prefix for OCaml libraries built by the project. # By default they will be installed into the same directory of the `lablgtk2' # library or into ${ocaml_libraryprefix}, but you can change it if you really # want to install into a different, custom prefix. # *No* trailing slash should be included. libraryprefix=$(which 1>/dev/null ocamlfind && ocamlfind query lablgtk2) libraryprefix=${libraryprefix%/lablgtk2} libraryprefix=${libraryprefix:-$ocaml_libraryprefix} # # This definition may be appropriate for debian packaging: #libraryprefix=debian/tmp/${ocaml_libraryprefix} # This should be defined as the absolute path to a directory containing # the already configured OCaml source; in alternative, is your GNU/Linux # distribution packages OCaml headers (debian and its offspring install # headers in /usr/include/caml), you can set this to the full path of # the directory containing OCaml headers. ocaml_sources=${ocaml_libraryprefix}/caml # # This definition is appropriate for debian-like distributions: #ocaml_sources=/usr/include/caml # # This is reasonable if you have downloaded and configured the OCaml # sources yourself, somewhere: #ocaml_sources=/home/luca/projects-by-others/ocaml-3.11.2 ########################################################################### # Section 3: Default configuration. This will end up in /etc/$name at # installation time, providing the default host configuration for this # package. Individual users can still override defaults by defining their # own ~/.$name customization file. ocamlbricks-0.90+bzr456.orig/GETTEXT/0000755000175000017500000000000013175721005016047 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/GETTEXT/README0000644000175000017500000000320113175721005016723 0ustar lucaslucasThis file is part of our reusable OCaml BRICKS library Copyright (C) 2009 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . This is a very simple OCaml wrapper for GNU Gettext, allowing for internationalization of messages in OCaml programs. Date, time and more advanced features like plurals are *not* currently supported. The interface is extremely simple: it suffices to initialize gettext support at startup time by calling initialize_gettext, which takes two parameters: the text domain, and the locale directory. After that, strings can be translated by simply calling gettext, taking an English string and returning a translated string. gettext is thread-safe and can be called without any external synchronization. gettext has an alias with a shorter name, s_. You can use f_ for format strings to be passed to Printf.printf and friends. An example is included: see gettext_example.ml. The Gettext ocaml wrapper is free software; it's released under the GPL version 2 or, at your option, any later version released by the Free Software Foundation. -- Luca Saiu, 2009-04-09 ocamlbricks-0.90+bzr456.orig/GETTEXT/gettext-example.ml0000644000175000017500000000300313175721005021512 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009, 2010 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* This is just a trivial example showing how to use our gettext wrapper: *) (* This uses the translations of GNU Hello, (http://www.gnu.org/software/hello) which are assumed to be found in /usr/share/locale. Of course you can change this: *) module Gettext = Gettext_builder.Make(struct let text_domain = "hello";; let directory = "/usr/share/locale";; end);; (* We want to just use s_ and f_: *) open Gettext;; (* The strings below are really used in GNU Hello. Of course you can't replace them with other messages, unless you also have translations: *) Printf.printf "%s" (s_ "hello, world\n");; Printf.printf (f_ "hello, world\n");; Printf.printf (f_ "Try `%s --help' for more information.\n") "foo";; Printf.printf (f_ "Report bugs to <%s>.\n") "foo@foo.foo";; ocamlbricks-0.90+bzr456.orig/GETTEXT/gettext_extract_pot_p4.ml0000644000175000017500000000606113175721005023107 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2010 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Generate a file .ml.pot during the .ml parsing. *) open Camlp4 (* -*- camlp4o -*- *) (* ocamlc -I +camlp4 -pp camlp4of.opt camlp4lib.cma gettext_extract_pot_p4.ml *) module Id = struct let name = "gettext_extract_pot_p4.ml" let version = "$Id: gettext_extract_pot_p4,v 0.1 2009/04/10 16:16:16 $" end let pp_name = "gettext_extract_pot_p4" module Tool = struct INCLUDE "CAMLP4/common_tools_for_preprocessors.ml" end let header = let file = "gettext_extract_pot_p4.conf" in let project_id_version = Tool.Conf.conf file ~default:"project_id_version???" "project_id_version" in let report_bugs_to = Tool.Conf.conf file ~default:"report_bugs_to???" "report_bugs_to" in let charset = Tool.Conf.conf file ~default:"utf-8" "charset" in Printf.sprintf "# Copyright (C) OWNER # AUTHOR, YEAR. # msgid \"\" msgstr \"\" \"Project-Id-Version: %s\\n\" \"Report-Msgid-Bugs-To: %s\\n\" \"Content-Type: text/plain; charset=%s\\n\" " project_id_version report_bugs_to charset module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax let append = let fd_ref = ref None in (* In order to open the file once *) let ht = Hashtbl.create 251 in (* In order to avoid duplicates *) fun _loc ?(msgstr="") msgid -> if Hashtbl.mem ht msgid then () else begin Hashtbl.add ht msgid (); let fd = match !fd_ref with | None -> let fname = ((Loc.file_name _loc)^".pot") in let fd = open_out fname in (fd_ref := Some fd); (output_string fd header); fd | Some fd -> fd in let line = Loc.start_line _loc in let fname = Loc.file_name _loc in let content = Printf.sprintf " #. generated by %s #: %s:%d msgid \"%s\" msgstr \"%s\"\n" pp_name fname line msgid msgstr in (output_string fd content); (flush fd) end EXTEND Gram GLOBAL: expr; gettext_id : [[ LIDENT "s_" -> "s_" ] | [ LIDENT "f_" -> "f_" ]]; expr: FIRST [[ id = gettext_id; msgid = STRING ; msgstr = STRING -> let () = append _loc msgid ~msgstr in <:expr< $lid:id$ $str:msgid$ >> | id = gettext_id; msgid = STRING -> let () = append _loc msgid in <:expr< $lid:id$ $str:msgid$ >> ]]; END end let module M = Register.OCamlSyntaxExtension (Id) (Make) in () ocamlbricks-0.90+bzr456.orig/GETTEXT/gettext_builder.mli0000644000175000017500000000455513175721005021755 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2009, 2010 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Build your application-dependent gettext wrapper. {b Example}. This example uses the translations of GNU Hello, (http://www.gnu.org/software/hello) which are assumed to be found in /usr/share/locale. Of course you can change this: {[module Gettext = Gettext_builder.Make(struct let text_domain = "hello" let directory = "/usr/share/locale" end);; (* We want to just use s_ and f_: *) open Gettext;; (* The strings below are really used in GNU Hello. Of course you can't replace them with other messages, unless you also have translations: *) Printf.printf "%s" (s_ "hello, world\n");; Printf.printf (f_ "hello, world\n");; Printf.printf (f_ "Try `%s --help' for more information.\n") "foo";; Printf.printf (f_ "Report bugs to <%s>.\n") "foo\@foo.foo";; ]}*) (** In order to build translators, we just need a text domain and a directory holding translated strings: *) module type TextDomainAndDirectory = sig val text_domain : string;; val directory : string;; end;; (** A Gettext module provides translation functions: *) module type Gettext = sig (** Translate a string: *) val s_ : string -> string;; (** Translate a format string: *) val f_ : (('a, 'b, 'c) format) -> (('a, 'b, 'c) format);; end;; (** Given the information above, we provide a Gettext module: *) module Make : functor (TheTextDomainAndDirectory : TextDomainAndDirectory) -> Gettext;; (** "Low-level" interface: given a text domain and a string in English, return its translated version. Before using this you must have called the functor with the same text domain and a suitable directory. *) val dgettext : string -> string -> string;; ocamlbricks-0.90+bzr456.orig/GETTEXT/gettext_builder.ml0000644000175000017500000000540013175721005021572 0ustar lucaslucas(*This file is part of our reusable OCaml BRICKS library Copyright (C) 2009, 2010 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* Make the primitives implemented in C visible to the OCaml world: *) external non_thread_safe_dgettext_primitive : string -> string -> string = "dgettext_primitive";; external non_thread_safe_initialize_gettext : string -> string -> unit = "initialize_gettext_primitive";; (* Some precedures aren't thread-safe, so we should sequentialize concurrent calls with a mutex. This code is not very performance-critical anyway... *) let the_mutex = Mutex.create ();; let initialize_gettext text_domain locales_directory = Mutex.lock the_mutex; non_thread_safe_initialize_gettext text_domain locales_directory; Mutex.unlock the_mutex;; (* Wrap the main primitive within a thread-safe function: *) let dgettext text_domain string_in_english = Mutex.lock the_mutex; let result = non_thread_safe_dgettext_primitive text_domain string_in_english in Mutex.unlock the_mutex; result;; (* Because of some annoying limitation of OCaml I can't really understand, these definitions must be repeated here: *) module type TextDomainAndDirectory = sig val text_domain : string;; val directory : string;; end;; module type Gettext = sig val s_ : string -> string;; val f_ : (('a, 'b, 'c) format) -> (('a, 'b, 'c) format);; end;; module Make (TheTextDomainAndDirectory : TextDomainAndDirectory) : Gettext = struct (* Let's bind this text domain to the directory at functor application time: *) initialize_gettext TheTextDomainAndDirectory.text_domain TheTextDomainAndDirectory.directory;; (* Public versions for strings, with the type we like: *) let s_ english_string = dgettext TheTextDomainAndDirectory.text_domain english_string;; (* Public versions for format strings, with the type we like: *) let f_ english_format_string = let english_string = string_of_format english_format_string in let foreign_string = dgettext TheTextDomainAndDirectory.text_domain english_string in Scanf.format_from_string foreign_string english_format_string;; end;; ocamlbricks-0.90+bzr456.orig/GETTEXT/gettext-c-wrapper.c0000644000175000017500000001107213175721005021576 0ustar lucaslucas/*This file is part of our reusable OCaml BRICKS library Copyright (C) 2009, 2010 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #include #include #include #include #include #include #include /* If I don't #include caml/alloc.h then this module compiles fine, but then crashes at runtime. Funny, isn't it? */ #include #include /* Some part of the gettext initialization should only be performed once: */ static bool was_gettext_initialized = false; /* Initialize gettext, using the locale specified by the user with environment variables: */ void initialize_gettext_c(const char *text_domain, const char *locales_directory){ /* Set the locale if we have not initialized yet: */ if(! was_gettext_initialized){ if(setlocale (LC_ALL, "") == NULL) // "" means that we look at the environment printf("WARNING: setlocale() returned NULL. Inernationalization will not work.\n"); was_gettext_initialized = true; } // outer if /* Now we're sure that gettext is initialized. Bind the particular text domain the user requested: */ bindtextdomain(text_domain, locales_directory); /* Notice that we don't call textdomain() any longer, as we don't use gettext() any longer: we only use dgettext(), where the text domain is an explicit parameter. */ //textdomain(text_domain); //printf("[gettext was initialized: >%s<, >%s<]\n", text_domain, locales_directory); fflush(stdout); } /* Trivially convert the parameter representation and call another C function to do the work, paying attention not to violate the garbage collector constraints: */ CAMLprim value initialize_gettext_primitive(value text_domain, value locales_directory){ /* The two parameters are GC roots: */ CAMLparam2(text_domain, locales_directory); /* Convert from OCaml strings to C strings: */ char *text_domain_as_a_c_string = String_val(text_domain); char *locales_directory_as_a_c_string = String_val(locales_directory); /* Do the actual work: */ initialize_gettext_c(text_domain_as_a_c_string, locales_directory_as_a_c_string); /* Return. It's essential to use this macro, and not C's return statement: */ CAMLreturn(Val_unit); } /* Trivially convert the parameter representation and call another C function to do the work, paying attention not to violate the garbage collector constraints: */ CAMLprim value dgettext_primitive(value text_domain_as_an_ocaml_string, value english_text_as_an_ocaml_string){ /* The parameter is a GC root: */ CAMLparam2(text_domain_as_an_ocaml_string, english_text_as_an_ocaml_string); /* The result will be another root: the documentation says to declare it here, and I've seen that it's initialized to zero, so it's ok if I don't set it. A GC can occur in the body, and it won't see any uninitialized object of type value: */ CAMLlocal1(result_as_an_ocaml_string); /* Convert from OCaml strings to C strings: */ char *text_domain_as_a_c_string = String_val(text_domain_as_an_ocaml_string); char *english_text_as_a_c_string = String_val(english_text_as_an_ocaml_string); /* Do the actual work, obtaining a C string (which may be overwritten by the next gettext() call): */ char *result_as_a_c_string = dgettext(text_domain_as_a_c_string, english_text_as_a_c_string); /* Convert from a C string to an OCaml string, using a temporary variable which is of course another GC root. The variable will refer a *copy* of the string, so the buffer at result_as_a_c_string can be safely overwritten later: */ result_as_an_ocaml_string = caml_copy_string(result_as_a_c_string); /* printf("[gettext_primitive is about to return]\n"); fflush(stdout); */ /* Return. It's essential to use this macro, and not C's return statement: */ CAMLreturn(result_as_an_ocaml_string); } ocamlbricks-0.90+bzr456.orig/GETTEXT/gettext_extract_pot_p4.mli0000644000175000017500000000231013175721005023251 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2013 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (** Automatically generate a file .ml.pot during the .ml parsing. Example (in your Makefile): --------------------------- PP_OPTIONS=camlp4of -I +ocamlbricks gettext_extract_pot_p4.cmo # A file .ml.pot will be generated for each compiled .ml target: ocamlc -c -pp "$PP_OPTIONS" ... # Supposing we are working with ocamlbuild: _build/target.pot: target.byte @msgcat -s --use-first $(shell find _build/ -name "*.ml.pot") > $@ *) ocamlbricks-0.90+bzr456.orig/MARSHAL/0000755000175000017500000000000013175721005016012 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/MARSHAL/marshallable_classes.ml0000644000175000017500000015737113175721005022526 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see .*) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) IFNDEF OCAML4_02_OR_LATER THEN module Bytes = struct let create = String.create let set = String.set end ENDIF let marshallable_classes_version = "0.1" ;; let marshallable_classes_metadata () = Printf.sprintf "marshallable_classes version %s (executable %s) Copyright (C) 2012 Jean-Vincent Loddo, This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. " (marshallable_classes_version) (Sys.executable_name) ;; (* ********************************* * WARNINGS and TRACING * ********************************* *) let warnings = ref true ;; let enable_warnings () = (warnings := true);; let disable_warnings () = (warnings := false);; let are_warnings_enable () = !warnings let are_warnings_disabled () = not !warnings let tracing = ref false ;; let enable_tracing () = (tracing := true);; let disable_tracing () = (tracing := false);; let is_tracing_enable () = !tracing let is_tracing_disabled () = not !tracing (* ********************************* * TOOLS * ********************************* *) let with_open_in_bin ~filename mtdh = let in_channel = open_in_bin filename in let length = in_channel_length (in_channel) in let result = mtdh in_channel length in close_in in_channel; result ;; let with_open_out_bin ?(perm=0o644) ~filename mtdh = let file_exists = Sys.file_exists filename in let out_channel = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0 filename in let result = mtdh out_channel in close_out out_channel; if not file_exists then Unix.chmod filename perm else (); result ;; let get_file_content ~filename = with_open_in_bin ~filename (fun in_channel length -> let s = Bytes.create length in really_input in_channel s 0 length; s) ;; let set_file_content ?perm ~filename content = with_open_out_bin ?perm ~filename (fun out_channel -> output_string out_channel content) ;; (* A simple (but portable) hash function generating natural numbers in the range [0..(2^30)-1] with a uniform distribution. Note that the limit is exactly the value of max_int on 32-bit architectures, i.e. 1073741823 = (2^30)-1 *) let hash32 s = let max_int32 = 1073741823 in let s = Digest.to_hex (Digest.string s) in let max_int32_succ = Int64.succ (Int64.of_int max_int32) (* (2^30) *) in let hash_portion portion = let length = 8 in let offset = portion * length in let sub = Bytes.create (2+length) in let () = String.blit "0x" 0 sub 0 2 in let () = String.blit s offset sub 2 length in let i = Int64.of_string sub in (* 0..(16^8)-1 = 0..(2^32)-1 *) (Int64.rem i max_int32_succ) (* 0..max_int32 *) in let result = let xs = [ (hash_portion 0); (hash_portion 1); (hash_portion 2); (hash_portion 3) ] in let sum = List.fold_left (fun s x -> Int64.add s x) Int64.zero xs in let remainder = Int64.rem (sum) (max_int32_succ) in (* 0..max_int32 *) Int64.to_int (remainder) in result ;; module Option = struct let extract = function | None -> failwith "Option.extract" | Some x -> x let map f = function None -> None | Some x -> Some (f x) let iter f = function None -> () | Some x -> (f x) let extract_or_force xo y = match xo with | Some x -> x | None -> Lazy.force y (* To manage the type `unit option' which is isomorphic to bool: *) let switch (opt) (case_None) (case_Some) = match opt with | None -> case_None | Some () -> case_Some end (* Option *) type oid = Oid of int type next_index = int type magic = int ref (* just a pointer... *) type ('a,'b) either = Left of 'a | Right of 'b module Extend_Map = functor (M:Map.S) -> struct include M let of_list (xs : (key * 'a) list) : 'a t = List.fold_left (fun m (k,a) -> add k a m) empty xs let to_list (m : 'a t) = fold (fun k a xs -> (k,a)::xs) m [] let filter_mapi (p : key -> 'a -> bool) (f:key -> 'a -> 'b) (m : 'a t) : 'b t = fold (fun k a m' -> if p k a then add k (f k a) m' else m') m empty let product (m1:'a t) (m2:'b t) : ('a * 'b) t = filter_mapi (fun k _ -> mem k m2) (fun k a -> (a, (find k m2))) m1 let length (m : 'a t) = fold (fun k a n -> n+1) m 0 end (* Note that compare is a flipped version of the provided one in order to have the result of to_list automatically sorted by key (from the lesser to the greater key, in the sense of the provided compare). *) module Map_Make (Ord : Map.OrderedType) = Extend_Map (Map.Make (struct include Ord let compare x y = compare y x end)) module Oid_map = Map_Make (struct type t = oid let compare = compare end) module Int_map = Map_Make (struct type t = int let compare = compare end) module String_map = Map_Make (struct type t = string let compare = compare end) (* ********************************* * Basic class constructors * ********************************* *) type 'a whatever_object = < .. > as 'a type 'a basic_class_constructor = unit -> 'a whatever_object let basic_class_constructors = ref String_map.empty let bcc = basic_class_constructors (* convenient alias *) let register_basic_constructor ~(class_name:string) (f: 'a basic_class_constructor) = let f () = if is_tracing_disabled () then f () else begin Printf.kfprintf flush stderr "\n--- loading: creating instance for class `%s' BEGIN\n" class_name; let result = f () in Printf.kfprintf flush stderr "--- loading: created object %d for class `%s' END\n\n" (Oo.id result) class_name; result end in bcc := String_map.add class_name (Obj.magic f) !bcc let get_basic_constructor ~involved_field ~involved_class class_name : 'a basic_class_constructor = try Obj.magic (String_map.find class_name !bcc) with Not_found -> invalid_arg (Printf.sprintf "Error: loading field `%s.%s' needs to recreate `%s' instances but this class has not a registered basic constructor." involved_class involved_field class_name) let search_a_basic_constructor_for class_name : (string, 'a basic_class_constructor) either = try Right (Obj.magic (String_map.find class_name !bcc)) with Not_found -> let warning_msg = (Printf.sprintf "Warning: loading would need to recreate a `%s' foreign instance but this class is not defined in this program." class_name) in Left warning_msg (* **************************************** * Marshalling/Unmarshalling environments * **************************************** *) type index = int (* In any case marshallable without closures: *) type marshallable = | Pointer of index (* to an object or a string (representing the object) *) | Datum of magic (* something marshallable without closures *) type field_name = string type labelled_values = (field_name * marshallable) (* ordered *) list type unlabelled_values = marshallable list (* This structure requires a saving or loading environment in order to be meaningfull. (because we have to correctly interpret pointers) *) type object_structure = { class_name : string option; labelled_values : (field_name * marshallable) (* ordered *) list; unlabelled_values : marshallable list; } (* The ready-to-be-marshalled structure representing objects: *) type object_closure = index_struct_list * object_structure and index_struct_list = (index * object_structure) (* ordered *) list (* Environments used for marshalling (saving): *) module Saving_env = struct type t = next_index * oid_index_env * index_struct_env and oid_index_env = index Oid_map.t (* oid -> index *) and index_struct_env = object_structure Int_map.t (* index -> object_structure *) let initial ~parent_oid = let parent_index = 0 in let next_index = parent_index+1 in let oid_index_env = Oid_map.add (Oid parent_oid) (parent_index) (Oid_map.empty) in let index_struct_env = Int_map.empty in (next_index, oid_index_env, index_struct_env) let search_index_by_oid oid t = let (next_index, oid_index_env, index_struct_env) = t in try Some (Oid_map.find oid oid_index_env) with Not_found -> None let add_oid_and_get_index (oid:oid) (t:t) : (t * index) = let (next_index, oid_index_env, index_struct_env) = t in let index = next_index in let oid_index_env' = Oid_map.add oid index oid_index_env in let next_index' = index + 1 in let t' = (next_index', oid_index_env', index_struct_env) in (t', index) let add_object_structure (index:index) (str:object_structure) (t:t) : t = let (next_index, oid_index_env, index_struct_env) = t in let index_struct_env' = Int_map.add index str index_struct_env in let t' = (next_index, oid_index_env, index_struct_env') in t' let extract_index_struct_env (t:t) : (index * object_structure) (* ordered *) list = let (next_index, oid_index_env, index_struct_env) = t in Int_map.to_list index_struct_env end (* module Saving_env *) (* Unmarshalling environments: *) module Loading_env = struct type t = { (* index -> (Left of object_structure | Right of object) *) index_map : ((object_structure, magic) either) Int_map.t; options : loading_options; } and loading_options = { mapping : (field_name->field_name) option; try_to_preserve_upcasting : unit option; try_to_reuse_living_objects : unit option; } (* This function is the unique way to build options. It will be exported in the .mli. *) let make_loading_options ?(mapping:(field_name -> field_name) option) ?(mapping_by_list:((field_name * field_name) list) option) ?try_to_preserve_upcasting ?try_to_reuse_living_objects () : loading_options = let mapping = match mapping, mapping_by_list with | None, None -> None | Some f, None -> Some f | None, Some l -> let smap = String_map.of_list l in Some (fun field -> String_map.find field smap) | Some f, Some l -> let smap = String_map.of_list l in Some (fun field -> try (f field) with _ -> (String_map.find field smap)) in (* Simply ignore mapping failures: *) let mapping = Option.map (fun f -> fun x -> try f x with _ -> x) mapping in { mapping = mapping; try_to_preserve_upcasting = try_to_preserve_upcasting; try_to_reuse_living_objects = try_to_reuse_living_objects; } let get_structure_or_object_by_index index t = Int_map.find (index) t.index_map let replace_structure_with_object (index:index) obj t = {t with index_map = Int_map.add index (Right obj) t.index_map; } let initial ?options ~(parent:magic) ~(index_struct_list: (index * object_structure) list) () = let parent_index = 0 in let index_struct_env = Int_map.of_list index_struct_list in let imported_index_struct_env = Int_map.map (fun str -> Left str) index_struct_env in let options = match options with | None -> make_loading_options () | Some options -> options in { index_map = Int_map.add parent_index (Right parent) (imported_index_struct_env); options = options;} let extract_label_mapping t = t.options.mapping let create_or_recycle_object_according_to_options ~(field_declared_class_name:string option) ~(foreign_class_name:string option) ~(object_maker) (* if the getter is not provided, the maker is used instead: *) ?(object_getter = object_maker) t = let switch = Option.switch in if (t.options.try_to_preserve_upcasting = None) || (foreign_class_name = None) || (foreign_class_name = field_declared_class_name) (* no upcasting *) then (* It's a simple case: create or reuse according to the associated option: *) switch (t.options.try_to_reuse_living_objects) (object_maker) (object_getter) else (* We try to preserve upcasting *and* the foreign class is defined *and* the foreign class is not the declared class of the field (there is an upcasting to preserve): *) let foreign_class_name = Option.extract foreign_class_name in match search_a_basic_constructor_for (foreign_class_name) with | Left warning_msg -> (* --- there isn't a local constructor for the foreign class, so we can't preserve upcasting anyway: *) (if are_warnings_enable () then Printf.kfprintf flush stderr "%s\n" warning_msg); switch (t.options.try_to_reuse_living_objects) (object_maker) (object_getter) (* --- *) | Right foreign_class_maker-> (* --- there is a local constructor for the foreign class. Now the question became: can the current instance be reused? *) let current_object_class_name = (object_getter ())#marshaller#parent_class_name in if current_object_class_name = (Some foreign_class_name) then (* Yes, it can be reused (according to the option) because it belongs to the same class: *) switch (t.options.try_to_reuse_living_objects) (foreign_class_maker) (object_getter) else (* No, it cannot be reused, we have to create a new object: *) foreign_class_maker end (* module Saving_env *) (* Elements to be exported (in the interface): *) type loading_options = Loading_env.loading_options let make_loading_options = Loading_env.make_loading_options type saving_env = Saving_env.t type loading_env = Loading_env.t module Fields_register = struct (* Variables that I call "saa" are of this type: *) type adapted_accessors = { get : Saving_env.t -> unit -> marshallable * Saving_env.t; set : Loading_env.t -> marshallable -> unit * Loading_env.t; } type t = { anonymous_fields : adapted_accessors list; (* The order here is relevant *) named_fields : adapted_accessors String_map.t; (* field-name -> adapted_accessors *) } let empty : t = { anonymous_fields = []; named_fields = String_map.empty; } let add ?field_name saa t = match field_name with | None -> {t with anonymous_fields=(saa :: t.anonymous_fields)} | Some name -> {t with named_fields = String_map.add name saa t.named_fields} let match_named_fields_with_labelled_values ?foreign_class_name ?class_name ?label_mapping (t:t) (labelled_values: (string * 'a) list) : (adapted_accessors * 'a) list = let labelled_values = match label_mapping with | None -> labelled_values | Some f -> List.map (fun (k,v) -> ((f k),v)) labelled_values in let labelled_values = String_map.of_list labelled_values in let matching = String_map.product t.named_fields labelled_values in let matching_as_list = String_map.to_list matching in let () = if are_warnings_disabled () then () else let nf = String_map.length t.named_fields in let nv = String_map.length labelled_values in let nm = List.length matching_as_list in let what = lazy (match class_name with | None -> "an object" | Some name -> Printf.sprintf "a `%s' instance" name) in match (compare nf nv), (nm < (min nf nv)) with | -1, false -> Printf.kfprintf flush stderr "Warning: loading %s from a serialized richer object (%d/%d labelled values taken).\n" (Lazy.force what) nf nv | 1, false -> Printf.kfprintf flush stderr "Warning: loading %s from a serialized poorer object (%d/%d labelled values taken).\n" (Lazy.force what) nf nv | 0, false -> () | _ -> Printf.kfprintf flush stderr "Warning: loading %s from a serialized different object (%d common fields, %d unloaded fields, %d unused values).\n" (Lazy.force what) nm (nf-nm) (nv-nm) in (* Now forget field names: *) List.map snd matching_as_list let match_anonymous_fields_with_unlabelled_values ?foreign_class_name ?class_name (t:t) (unlabelled_values: 'a list) : (adapted_accessors * 'a) list = let what = lazy (match class_name with | None -> "an object" | Some name -> Printf.sprintf "a `%s' instance" name) in let rec combine fs vs = match (fs, vs) with | ([],[]) -> [] | (f::fs, v::vs) -> (f,v)::(combine fs vs) | ([],_) -> let () = if are_warnings_disabled () then () else Printf.kfprintf flush stderr "Warning: loading the anonymous fields of %s from a serialized richer object (%d/%d values taken).\n" (Lazy.force what) (List.length t.anonymous_fields) (List.length unlabelled_values) in [] | (_,[]) -> let () = if are_warnings_disabled () then () else Printf.kfprintf flush stderr "Warning: loading the anonymous fields of %s from a serialized poorer object (%d/%d values taken).\n" (Lazy.force what) (List.length t.anonymous_fields) (List.length unlabelled_values) in [] in combine t.anonymous_fields unlabelled_values end (* module Fields_register *) class marshallable_class ?name ~(marshaller:marshaller option ref) () = let shared_marshaller = marshaller in object (self) (* When objects will be initialized, the shared_marshaller will be defined once by the first inherited, that is precisely this class (marshallable_class): *) method marshaller : marshaller = match !shared_marshaller with Some x -> x | None -> assert false (* The first initializer wins: *) initializer match !shared_marshaller with | None -> begin let created_marshaller = new marshaller ?parent_class_name:name ~parent:(self :> (marshallable_class)) () in let () = if is_tracing_disabled () then () else Printf.kfprintf flush stderr "creating: %s.marshallable_class(%d).initializer: created the marshaller %d\n" (Option.extract name) (Oo.id self) (Oo.id created_marshaller) in shared_marshaller := (Some created_marshaller); (* Release the information to the parent *) end | Some m -> let () = if is_tracing_disabled () then () else Printf.kfprintf flush stderr "creating: %s.marshallable_class(%d).initializer: sharing the marshaller %d\n" (Option.extract name) (Oo.id self) (Oo.id m) in () (* It's fine, a shared marshaller has been already created *) end and (* class *) marshaller ?parent_class_name ~(parent:marshallable_class) () = let _WITHOUT_CLOSURES_OF_COURSE = [] in object (self) val parent_class_name : string option = parent_class_name method parent_class_name = parent_class_name val mutable fields_register : Fields_register.t = Fields_register.empty method private get_fields_register = fields_register method private get_anonymous_fields = fields_register.Fields_register.anonymous_fields method private get_named_fields_as_ordered_assoc_list = let m = fields_register.Fields_register.named_fields in String_map.to_list m method private register_adapted_accessors ?field_name (saa : Fields_register.adapted_accessors) = fields_register <- (Fields_register.add ?field_name saa fields_register) (* ----------------------------- Registering SIMPLE fields ----------------------------- *) method private adapt_simple_field : 'a. (unit -> 'a) -> ('a -> unit) -> Fields_register.adapted_accessors = fun real_get real_set -> let adapted_get : Saving_env.t -> unit -> marshallable * Saving_env.t = fun saving_env () -> let x = real_get () in let datum = Datum (Obj.magic x) in (datum, saving_env) in let adapted_set : Loading_env.t -> marshallable -> unit * Loading_env.t = fun loading_env -> function | Datum x -> ((real_set (Obj.magic x)), loading_env) | Pointer index -> assert false in { Fields_register.get = adapted_get; Fields_register.set = adapted_set} method register_simple_field : 'a. ?name:string -> (unit -> 'a) -> ('a -> unit) -> unit = fun ?name real_get real_set -> self#register_adapted_accessors ?field_name:name (self#adapt_simple_field real_get real_set) (* ----------------------------- Registering OBJECT fields ----------------------------- *) (* To be used with map_and_fold (map the first result, fold the second) *) method private marshallable_of_object : Saving_env.t -> (< marshaller:marshaller; .. > as 'a) -> marshallable * Saving_env.t = fun saving_env obj -> let oid = Oid (Oo.id obj) in (* The result is always a pointer (the string is stored in the saving_env): *) match Saving_env.search_index_by_oid oid saving_env with | Some index -> (if is_tracing_enable () then Printf.kfprintf flush stderr "saving: making a pointer to index %d\n" index); let pointer = (Pointer index) in (pointer, saving_env) | None -> let (saving_env, index) = Saving_env.add_oid_and_get_index oid saving_env in (if is_tracing_enable () then Printf.kfprintf flush stderr "saving: added object oid %d with index %d\n" (Oo.id obj) index); let (str, saving_env) = obj#marshaller#protected_save_to_object_structure saving_env in let saving_env = Saving_env.add_object_structure index str saving_env in let pointer = (Pointer index) in (pointer, saving_env) method private object_of_marshallable (* : .. -> .. -> object * loading_env *) = fun ?getter ~maker loading_env -> function | Pointer index -> begin match Loading_env.get_structure_or_object_by_index index loading_env with | Left (obj_structure : object_structure) -> let create_or_recycle_object = Loading_env.create_or_recycle_object_according_to_options ~field_declared_class_name:None ~foreign_class_name:(obj_structure.class_name) ~object_maker:maker ?object_getter:getter loading_env in let obj = create_or_recycle_object () in (if is_tracing_enable () then Printf.kfprintf flush stderr "loading: adding object oid %d with index %d before loading it\n" (Oo.id obj) index); let loading_env = Loading_env.replace_structure_with_object index (Obj.magic obj) loading_env in let (), loading_env = obj#marshaller#protected_load_from_object_structure (loading_env) (obj_structure) in (obj, loading_env) | Right obj -> (if is_tracing_enable () then Printf.kfprintf flush stderr "loading: found object oid %d with index %d\n" (Oo.id (Obj.magic obj)) index); (Obj.magic obj), loading_env end (* of Pointer's case *) | Datum _ -> assert false method private adapt_object_field : (unit -> (< marshaller : marshaller; .. >)) -> (* object maker *) (unit -> (< marshaller:marshaller; .. >)) -> (* The real get-accessor of the field *) (< marshaller:marshaller; .. > -> unit) -> (* The real set-accessor of the field *) Fields_register.adapted_accessors = fun object_maker real_get real_set -> let adapted_get : Saving_env.t -> unit -> marshallable * Saving_env.t = fun saving_env () -> let obj = real_get () in self#marshallable_of_object saving_env obj in let adapted_set : Loading_env.t -> marshallable -> unit * Loading_env.t = fun loading_env marshallable -> let (obj, loading_env) = self#object_of_marshallable ~getter:(real_get) ~maker:(object_maker) (loading_env) (marshallable) in ((real_set (Obj.magic obj)), loading_env) in { Fields_register.get = adapted_get; Fields_register.set = adapted_set} method register_object_field : 'obj. ?name:string -> (unit -> (< marshaller : marshaller; .. > as 'obj)) -> (* object maker *) (unit -> 'obj) -> (* getter *) ('obj -> unit) -> (* setter *) unit = Obj.magic begin fun ?name (object_maker:unit->'obj) real_get real_set -> let object_maker : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker in (self#register_adapted_accessors ?field_name:name (self#adapt_object_field object_maker real_get real_set)) end (* ----------------------------------------- Registering FUNCTORIZED OBJECT fields ----------------------------------------- *) method private adapt_functorized_object_field : 'obj_t 'a_t 'b_t 'ab_t. ?zip:('a_t -> 'b_t -> 'ab_t) -> (* functor zip *) (((< marshaller : marshaller; .. > as 'obj) -> marshallable) -> 'obj_t -> marshallable) -> (* functor map1 *) ((marshallable -> 'obj) -> marshallable -> 'obj_t) -> (* functor map2 *) (unit -> 'obj) -> (* object maker *) (unit -> 'obj_t) -> (* getter *) ('obj_t -> unit) -> (* setter *) Fields_register.adapted_accessors (* result *) = fun ?zip map1 map2 object_maker real_get real_set -> let adapted_get : Saving_env.t -> unit -> marshallable * Saving_env.t = fun saving_env () -> let object_t = real_get () in let marshallable_t, saving_env = (Functor.map_and_fold_of_functor map1) (self#marshallable_of_object) (saving_env) object_t in (Datum (Obj.magic marshallable_t), saving_env) in let adapted_set : Loading_env.t -> marshallable -> unit * Loading_env.t = fun loading_env -> let zip = Obj.magic zip in function | Datum x when zip=None -> let marshallable_t = Obj.magic x in let object_t, loading_env = (Functor.map_and_fold_of_functor map2) (self#object_of_marshallable ~maker:object_maker) (loading_env) marshallable_t in ((real_set object_t), loading_env) | Datum x (* when zip<>None *) -> let marshallable_t = Obj.magic x in let zip = Option.extract zip in let living_object_t = real_get () in let object_t, loading_env = try (* The following definition is commented in order to avoid a boring warning: *) (* let marshallable_object_t = zip marshallable_t living_object_t in (* this call may fail *) *) (Functor.map_and_fold_of_functor (Obj.magic map2)) (fun env (msh,liv_obj) -> self#object_of_marshallable ~getter:(fun ()->liv_obj) ~maker:object_maker env msh) (loading_env) ((Obj.magic zip) marshallable_t living_object_t) (* marshallable_object_t *) with _ -> begin (* Ignore zip: *) (Functor.map_and_fold_of_functor map2) (self#object_of_marshallable ~maker:object_maker) (loading_env) marshallable_t end in ((real_set object_t), loading_env) (* The field is a non-object structure containing objects *) | Pointer _ -> (assert false) in { Fields_register.get = adapted_get; Fields_register.set = adapted_set} method register_functorized_object_field : 'obj 'obj_t 'a 'b 'a_t 'b_t 'ab_t. ?name:string -> (* name *) ?zip:('a_t -> 'b_t -> 'ab_t) -> (* functor zip *) (('a -> 'b) -> 'a_t -> 'b_t) -> (* functor *) (unit -> (< marshaller : marshaller; .. > as 'obj)) -> (* object maker *) (unit -> 'obj_t) -> (* getter *) ('obj_t -> unit) -> (* setter *) unit = fun ?name ?zip functor_map object_maker real_get real_set -> let map1 = Obj.magic functor_map in let map2 = Obj.magic functor_map in (* Because of a strange typing problem: *) let object_maker : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker in self#register_adapted_accessors ?field_name:name (self#adapt_functorized_object_field ?zip map1 map2 object_maker real_get real_set) (* --------------------------------------------- Registering BI-FUNCTORIZED OBJECTS fields --------------------------------------------- *) method private adapt_bifunctorized_objects_field : 'objects_t 'au_t 'bv_t 'axb_uxv_t . (* bifunctor zip *) ?zip:('au_t -> 'bv_t -> 'axb_uxv_t) -> (* bifunctor map1 *) (((< marshaller : marshaller; .. > as 'obj1) -> marshallable) -> ((< marshaller : marshaller; .. > as 'obj2) -> marshallable) -> 'objects_t -> marshallable) -> (* bifunctor map2 *) ((marshallable -> 'obj1) -> (marshallable -> 'obj2) -> marshallable -> 'objects_t) -> (unit -> 'obj1) -> (* object maker 1 *) (unit -> 'obj2) -> (* object maker 2 *) (unit -> 'objects_t) -> (* getter *) ('objects_t -> unit) -> (* setter *) Fields_register.adapted_accessors (* result *) = fun ?zip map1 map2 object_maker1 object_maker2 real_get real_set -> let adapted_get : Saving_env.t -> unit -> marshallable * Saving_env.t = fun saving_env () -> let objects_t = real_get () in let marshallable_t, saving_env = (Functor.map_and_fold_of_bifunctor map1) (self#marshallable_of_object) (self#marshallable_of_object) (saving_env) objects_t in (Datum (Obj.magic marshallable_t), saving_env) in let adapted_set : Loading_env.t -> marshallable -> unit * Loading_env.t = fun loading_env -> let zip = Obj.magic zip in function | Datum x when zip=None -> let marshallable_t = Obj.magic x in let objects_t, loading_env = (Functor.map_and_fold_of_bifunctor map2) (self#object_of_marshallable ~maker:object_maker1) (self#object_of_marshallable ~maker:object_maker2) (loading_env) marshallable_t in ((real_set objects_t), loading_env) | Datum x (*when zip<>None*) -> let marshallable_t = Obj.magic x in let zip = Option.extract zip in let living_objects_t = real_get () in let objects_t, loading_env = try (* The following definition is commented in order to avoid a boring warning: *) (* let marshallable_x_objects_t = zip marshallable_t living_objects_t in (* this call may fails *) *) (Functor.map_and_fold_of_bifunctor (Obj.magic map2)) (fun env (msh, liv_obj) -> self#object_of_marshallable ~getter:(fun ()->liv_obj) ~maker:object_maker1 env msh) (fun env (msh, liv_obj) -> self#object_of_marshallable ~getter:(fun ()->liv_obj) ~maker:object_maker2 env msh) (loading_env) ((Obj.magic zip) marshallable_t living_objects_t) (* marshallable_x_objects_t *) with _ -> begin (* Ignore zip: *) (Functor.map_and_fold_of_bifunctor map2) (self#object_of_marshallable ~maker:object_maker1) (self#object_of_marshallable ~maker:object_maker2) (loading_env) marshallable_t end in ((real_set objects_t), loading_env) (* The field is a non-object structure containing objects *) | Pointer _ -> (assert false) in { Fields_register.get = adapted_get; Fields_register.set = adapted_set} method register_bifunctorized_objects_field : 'obj1 'obj2 'objects_t 'a 'b 'c 'd 'ac_t 'bd_t 'au_t 'bv_t 'axb_uxv_t. ?name:string -> (* name *) ?zip:('au_t -> 'bv_t -> 'axb_uxv_t) -> (* zip for bifunctor *) (('a -> 'b) -> ('c -> 'd) -> 'ac_t -> 'bd_t) -> (* bifunctor *) (unit -> (< marshaller : marshaller; .. > as 'obj1)) -> (* object maker 1 *) (unit -> (< marshaller : marshaller; .. > as 'obj2)) -> (* object maker 2 *) (unit -> 'objects_t) -> (* getter *) ('objects_t -> unit) -> (* setter *) unit = fun ?name ?zip bifunctor_map object_maker1 object_maker2 real_get real_set -> let map1 = Obj.magic bifunctor_map in let map2 = Obj.magic bifunctor_map in (* Because of a strange typing problem: *) let maker1 : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker1 in let maker2 : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker2 in self#register_adapted_accessors ?field_name:name (self#adapt_bifunctorized_objects_field ?zip map1 map2 maker1 maker2 real_get real_set) (* --------------------------------------------- Registering TRI-FUNCTORIZED OBJECTS fields --------------------------------------------- *) method private adapt_trifunctorized_objects_field : 'objects_t 'ace_t 'bdf_t 'aue_t 'bvf_t 'axb_uxv_exf_t. (* trifunctor zip *) ?zip:('aue_t -> 'bvf_t -> 'axb_uxv_exf_t) -> (* trifunctor map1 *) (((< marshaller : marshaller; .. > as 'obj1) -> marshallable) -> ((< marshaller : marshaller; .. > as 'obj2) -> marshallable) -> ((< marshaller : marshaller; .. > as 'obj3) -> marshallable) -> 'objects_t -> marshallable) -> (* trifunctor map2 *) ((marshallable -> 'obj1) -> (marshallable -> 'obj2) -> (marshallable -> 'obj3) -> marshallable -> 'objects_t) -> (unit -> 'obj1) -> (* object maker 1 *) (unit -> 'obj2) -> (* object maker 2 *) (unit -> 'obj3) -> (* object maker 3 *) (unit -> 'objects_t) -> (* getter *) ('objects_t -> unit) -> (* setter *) Fields_register.adapted_accessors (* result *) = fun ?zip map1 map2 object_maker1 object_maker2 object_maker3 real_get real_set -> let adapted_get : Saving_env.t -> unit -> marshallable * Saving_env.t = fun saving_env () -> let objects_t = real_get () in let marshallable_t, saving_env = (Functor.map_and_fold_of_trifunctor map1) (self#marshallable_of_object) (self#marshallable_of_object) (self#marshallable_of_object) (saving_env) objects_t in (Datum (Obj.magic marshallable_t), saving_env) in let adapted_set : Loading_env.t -> marshallable -> unit * Loading_env.t = fun loading_env -> let zip = Obj.magic zip in function | Datum x when zip=None -> let marshallable_t = Obj.magic x in let objects_t, loading_env = (Functor.map_and_fold_of_trifunctor map2) (self#object_of_marshallable ~maker:object_maker1) (self#object_of_marshallable ~maker:object_maker2) (self#object_of_marshallable ~maker:object_maker3) (loading_env) marshallable_t in ((real_set objects_t), loading_env) | Datum x (*when zip<>None*) -> let marshallable_t = Obj.magic x in let zip = Option.extract zip in let living_objects_t = real_get () in let objects_t, loading_env = try (* The following definition is commented in order to avoid a boring warning: *) (* let marshallable_x_objects_t = zip marshallable_t living_objects_t in (* this call may fails *) *) (Functor.map_and_fold_of_trifunctor (Obj.magic map2)) (fun env (msh, liv_obj) -> self#object_of_marshallable ~getter:(fun ()->liv_obj) ~maker:object_maker1 env msh) (fun env (msh, liv_obj) -> self#object_of_marshallable ~getter:(fun ()->liv_obj) ~maker:object_maker2 env msh) (fun env (msh, liv_obj) -> self#object_of_marshallable ~getter:(fun ()->liv_obj) ~maker:object_maker3 env msh) (loading_env) ((Obj.magic zip) marshallable_t living_objects_t) (* marshallable_x_objects_t *) with _ -> begin (* Ignore zip: *) (Functor.map_and_fold_of_trifunctor map2) (self#object_of_marshallable ~maker:object_maker1) (self#object_of_marshallable ~maker:object_maker2) (self#object_of_marshallable ~maker:object_maker3) (loading_env) marshallable_t end in ((real_set objects_t), loading_env) (* The field is a non-object structure containing objects *) | Pointer _ -> (assert false) in { Fields_register.get = adapted_get; Fields_register.set = adapted_set} method register_trifunctorized_objects_field : 'obj1 'obj2 'obj3 'objects_t 'a 'b 'c 'd 'e 'f 'ace_t 'bdf_t 'aue_t 'bvf_t 'axb_uxv_exf_t . ?name:string -> (* name *) ?zip:('aue_t -> 'bvf_t -> 'axb_uxv_exf_t) -> (* trifunctor zip *) (('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> 'ace_t -> 'bdf_t) -> (* trifunctor *) (unit -> (< marshaller : marshaller; .. > as 'obj1)) -> (* object maker 1 *) (unit -> (< marshaller : marshaller; .. > as 'obj2)) -> (* object maker 2 *) (unit -> (< marshaller : marshaller; .. > as 'obj3)) -> (* object maker 3 *) (unit -> 'objects_t) -> (* getter *) ('objects_t -> unit) -> (* setter *) unit = fun ?name ?zip trifunctor_map object_maker1 object_maker2 object_maker3 real_get real_set -> let map1 = Obj.magic trifunctor_map in let map2 = Obj.magic trifunctor_map in (* Because of a strange typing problem: *) let maker1 : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker1 in let maker2 : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker2 in let maker3 : (unit -> < marshaller : marshaller; .. >) = Obj.magic object_maker3 in self#register_adapted_accessors ?field_name:name (self#adapt_trifunctorized_objects_field ?zip map1 map2 maker1 maker2 maker3 real_get real_set) (* -------------------------------------- S A V I N G (marshalling) -------------------------------------- *) method save_to_string : string = let object_closure = self#save_to_object_closure in Marshal.to_string (object_closure) (_WITHOUT_CLOSURES_OF_COURSE) method save_to_file filename = let object_closure = self#save_to_object_closure in with_open_out_bin ~filename (fun out_channel -> Marshal.to_channel out_channel (object_closure) (_WITHOUT_CLOSURES_OF_COURSE)) method private save_to_object_closure : object_closure = let (object_structure, saving_env) = self#protected_save_to_object_structure (Saving_env.initial ~parent_oid:(Oo.id parent)) in (* Extract now the index->string environment from the saving_env: *) let index_struct_list = Saving_env.extract_index_struct_env saving_env in let object_closure = (index_struct_list, object_structure) in object_closure method (* protected *) protected_save_to_object_structure (saving_env) : object_structure * Saving_env.t = let labelled_values, saving_env = self#save_to_labelled_values (saving_env) in let unlabelled_values, saving_env = self#save_to_unlabelled_values (saving_env) in let object_structure = { class_name = self#parent_class_name; labelled_values = labelled_values; unlabelled_values = unlabelled_values; } in (object_structure, saving_env) method private save_to_labelled_values (saving_env) = let (result: (string*marshallable) list), saving_env = List.fold_left (fun state ((name:string), (saa:Fields_register.adapted_accessors)) -> let result, saving_env = state in let (mshlable, saving_env) = saa.Fields_register.get saving_env () in let state' = ((name, mshlable)::result, saving_env) in state') ([], saving_env) self#get_named_fields_as_ordered_assoc_list (* NAMED FIELDS! *) in (result, saving_env) method private save_to_unlabelled_values (saving_env) = let (result: marshallable list), saving_env = List.fold_left (fun state (saa:Fields_register.adapted_accessors) -> let result, saving_env = state in let (mshlable, saving_env) = saa.Fields_register.get saving_env () in let state' = (mshlable::result, saving_env) in state') ([], saving_env) self#get_anonymous_fields (* ANONYMOUS FIELDS! *) in (List.rev result, saving_env) (* -------------------------------------- L O A D I N G (unmarshalling) -------------------------------------- *) (* Loading from a string: *) method load_from_string ?options (str:string) : unit = let object_closure = (Marshal.from_string str 0) in self#load_from_object_closure ?options object_closure (* Loading from a file: *) method load_from_file ?options filename : unit = let (object_closure : object_closure) = try with_open_in_bin ~filename (fun in_channel length -> Marshal.from_channel in_channel) with _ -> failwith "load_from_file: failed unmarshalling the file content" in self#load_from_object_closure ?options (object_closure) (* Loading from a object_closure: *) method private load_from_object_closure : ?options:loading_options -> object_closure -> unit = fun ?options object_closure -> let (index_struct_list, object_structure) = object_closure in let loading_env = Loading_env.initial ?options ~parent:(Obj.magic parent) ~index_struct_list () in let (), _loading_env = self#protected_load_from_object_structure (loading_env) (object_structure) in () (* Loading from a both labelled and unlabelled values. It's simply the composition of the two functions loading from labelled and from unlabelled values: *) method (* protected *) protected_load_from_object_structure (loading_env) (object_structure : object_structure) : unit * Loading_env.t = let foreign_class_name = object_structure.class_name and labelled_values = object_structure.labelled_values and unlabelled_values = object_structure.unlabelled_values in let (), loading_env = self#load_from_labelled_values ?foreign_class_name (loading_env) (labelled_values) in let (), loading_env = self#load_from_unlabelled_values ?foreign_class_name (loading_env) (unlabelled_values) in ((), loading_env) (* Loading from a list of labelled values: *) method private load_from_labelled_values ?foreign_class_name (loading_env) (labelled_values : (field_name * marshallable) list) : unit * Loading_env.t = let set_arg_list = let saa_arg_list = Fields_register.match_named_fields_with_labelled_values ?foreign_class_name ?class_name:(self#parent_class_name) ?label_mapping:(Loading_env.extract_label_mapping loading_env) (self#get_fields_register) (labelled_values) in List.map (fun (saa,arg) -> (saa.Fields_register.set,arg)) saa_arg_list in self#load_from_set_arg_list (loading_env) set_arg_list (* Loading from a list of unlabelled values: *) method private load_from_unlabelled_values ?foreign_class_name (loading_env) (unlabelled_values : marshallable list) : unit * Loading_env.t = let set_arg_list = let saa_arg_list = Fields_register.match_anonymous_fields_with_unlabelled_values ?foreign_class_name ?class_name:(self#parent_class_name) (self#get_fields_register) (unlabelled_values) in List.map (fun (saa,arg) -> (saa.Fields_register.set,arg)) saa_arg_list in self#load_from_set_arg_list (loading_env) set_arg_list method private load_from_set_arg_list (loading_env) set_arg_list : unit * Loading_env.t = let loading_env = List.fold_left (fun loading_env (set, arg) -> snd (set loading_env arg)) loading_env set_arg_list in ((), loading_env) (* -------------------------------------- Other methods -------------------------------------- *) method compare : 'a. (< marshaller:marshaller; .. > as 'a) -> int = fun obj -> Pervasives.compare (self#save_to_string) (obj#marshaller#save_to_string) method equals : 'a. (< marshaller:marshaller; .. > as 'a) -> bool = fun obj -> (self#save_to_string) = (obj#marshaller#save_to_string) method hash32 : int = hash32 (self#save_to_string) method md5sum : string = Digest.to_hex (Digest.string (self#save_to_string)) method remake_simplest : unit = self#load_from_string (self#save_to_string) (* Alias for remake_simplest: *) method remove_upcasting : unit = self#load_from_string (self#save_to_string) end;; (* ********************************* * Associated tools * ********************************* *) module Toolkit = struct (* Just an alias for List.combine: *) let zip_list = List.combine let zip_array xs ys = if (Array.length xs) <> (Array.length ys) then invalid_arg "zip_array" else Array.mapi (fun i a -> (a,ys.(i))) xs ;; let zip_option x y = match (x,y) with | (None, None) -> None | (Some x, Some y) -> Some (x,y) | _ -> invalid_arg "zip_option" let zip_either x y = match (x,y) with | (Either.Left a, Either.Left c) -> Either.Left (a,c) | (Either.Right b, Either.Right d) -> Either.Right (b,d) | _ , _ -> invalid_arg "zip_either" end (* ********************************* * Example * ********************************* *) IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Example = struct (* A concrete syntax like: tag (marshallable) class adds the parameter ?marshaller to all defined classes as first parameter *) class class1 ?(marshaller:(marshaller option ref) option) () = let marshaller = match marshaller with None -> ref None | Some r -> r in object (self) (* Automatically added at the beginning of the class definition: *) inherit marshallable_class ~name:"class1" ~marshaller () (* When a class is inherited, the parameter ~marshaller is given to the class constructor: inherit class0 expr => inherit ~marshaller class0 expr *) val mutable field0 = 16 method get_field0 = field0 method set_field0 v = field0 <- v initializer self#marshaller#register_simple_field ~name:"field0" (fun () -> self#get_field0) self#set_field0; val mutable field1 = "field1" method get_field1 = field1 method set_field1 v = field1 <- v initializer self#marshaller#register_simple_field ~name:"field1" (fun () -> self#get_field1) self#set_field1; val mutable field2 = Some 42 method get_field2 = field2 method set_field2 v = field2 <- v initializer self#marshaller#register_simple_field ~name:"field2" (fun () -> self#get_field2) self#set_field2; end (* end of class1.. *) (* ..but the class definition is not complete: we have to register its basic class constructor: *) let () = register_basic_constructor ~class_name:"class1" (fun () -> new class1 ()) class class2 ?(marshaller:(marshaller option ref) option) () = let marshaller = match marshaller with None -> ref None | Some r -> r in let involved_class = "class2" in object (self) (* Automatically added at the beginning of the class definition: *) inherit marshallable_class ~name:"class2" ~marshaller () (* Share the marshaller: *) inherit class1 ~marshaller () (* A field containing a (marshallable) object: Concrete syntax: tag (object) val mutable field3 : class1 = new class1 () In case of composition (not inheritance) I dont need to provide the same marshaller to the class constructor. *) val mutable field3 : class1 = new class1 () (* another marshaller! *) method get_field3 = field3 method set_field3 v = field3 <- v initializer let object_maker = get_basic_constructor "class1" ~involved_field:"field3" ~involved_class in self#marshaller#register_object_field ~name:"field3" object_maker (fun () -> self#get_field3) self#set_field3; (* A field containing an optional (marshallable) object: Concrete syntax: tag (object option) val mutable field4 : class2 option = None *) val mutable field4 : class2 option = None method get_field4 = field4 method set_field4 v = field4 <- v initializer (* from the tag: *) let object_maker = get_basic_constructor "class2" ~involved_field:"field4" ~involved_class in let functor_map = Option.map in (* from the tag: option -> Option.map *) self#marshaller#register_functorized_object_field ~name:"field4" ~zip:(fun x y -> match (x,y) with None,None-> None| Some x, Some y -> Some (x,y) | _,_ -> assert false) functor_map object_maker (fun () -> self#get_field4) self#set_field4 (* A field containing a list of (marshallable) objects: Concrete syntax: tag (object list) val mutable field4 : class2 list = None *) val mutable field5 : class2 list = [] method get_field5 = field5 method set_field5 v = field5 <- v initializer let object_maker = get_basic_constructor "class2" ~involved_field:"field5" ~involved_class in let functor_map = List.map in (* from the tag: list -> List.map *) self#marshaller#register_functorized_object_field ~name:"field5" ~zip:(List.combine) functor_map object_maker (fun () -> self#get_field5) self#set_field5 end (* end of class2.. *) (* ..but the class definition is not complete: we have to register its basic class constructor: *) let () = register_basic_constructor ~class_name:"class2" (fun () -> new class2 ()) class class3 ?(marshaller:(marshaller option ref) option) () = let marshaller = match marshaller with None -> ref None | Some r -> r in let involved_class = "class3" in object (self) (* Automatically added at the beginning of the class definition: *) inherit marshallable_class ~name:"class3" ~marshaller () (* Note that now `marshaller' stands for the inherited field (not the parameter): *) inherit class2 ~marshaller () val mutable field6 = '6' method get_field6 = field6 method set_field6 v = field6 <- v initializer self#marshaller#register_simple_field ~name:"field6" (fun () -> self#get_field6) self#set_field6; val mutable field7 : (class2, class3) Either.t = Either.Left (new class2 ()) method get_field7 = field7 method set_field7 v = field7 <- v initializer let object_maker1 = get_basic_constructor "class2" ~involved_field:"field7" ~involved_class in let object_maker2 = get_basic_constructor "class3" ~involved_field:"field7" ~involved_class in let functor_map = Either.Bifunctor.map in self#marshaller#register_bifunctorized_objects_field ~name:"field7" ~zip:(fun x y -> match x,y with (Left a, Left b) -> Left (a,b) | (Right c, Right d) -> Right (c,d) | _,_ -> assert false) functor_map object_maker1 object_maker2 (fun () -> self#get_field7) self#set_field7 end let () = register_basic_constructor ~class_name:"class3" (fun () -> new class3 ()) let crash_test () = let x = new class3 () in let y = new class3 () in assert ((x=y) = false); (* but *) assert (x#marshaller#equals y); let z1 = new class2 () in let z2 = new class2 () in let load_y_with_x ?reuse ?upcasting () = let options = make_loading_options ?try_to_preserve_upcasting:upcasting ?try_to_reuse_living_objects:reuse () in y#marshaller#load_from_string ~options (x#marshaller#save_to_string) in x#set_field5 [z1; z2]; assert (not (x#marshaller#equals y)); load_y_with_x (); assert (x#marshaller#equals y); (* --- Test objects' reusing: *) let oid1 = Oo.id (List.hd (x#get_field5)) in let oid2 = Oo.id (List.hd (y#get_field5)) in assert (oid1 <> oid2); load_y_with_x (); let oid3 = Oo.id (List.hd (y#get_field5)) in assert (oid2 <> oid3); load_y_with_x ~reuse:() (); let oid4 = Oo.id (List.hd (y#get_field5)) in assert (oid3 = oid4); (* --- A little change in (the graph of) x: *) assert (x#marshaller#equals y); z1#set_field0 1234; assert (not (x#marshaller#equals y)); let z1' = List.hd y#get_field5 in assert (not (z1#marshaller#equals z1')); z1'#set_field0 1234; assert (z1#marshaller#equals z1'); assert (x#marshaller#equals y); (* --- Test bifunctors: *) let z = new class3 () in x#set_field7 (Either.Right z); assert (not (x#marshaller#equals y)); load_y_with_x (); assert (x#marshaller#equals y); (* --- Test reusing with bifunctors (zip): *) let oid1 = Oo.id (Either.get_right (y#get_field7)) in load_y_with_x (); let oid2 = Oo.id (Either.get_right (y#get_field7)) in assert (oid1 <> oid2); load_y_with_x ~reuse:() (); let oid3 = Oo.id (Either.get_right (y#get_field7)) in assert (oid2 = oid3); (* --- Test cyclicity and casting: *) x#set_field3 (x :> class1); assert (not (x#marshaller#equals y)); load_y_with_x (); (* because loops are recognized and reproduced identically: *) assert (x#marshaller#equals y); (* but... *) x#set_field3 (z1 :> class1); load_y_with_x (); (* now field3 is not a loop: *) assert (not (x#marshaller#equals y)); (* we have to set the option ~try_to_preserve_upcasting *) load_y_with_x ~upcasting:() (); (* now it's fine: *) assert (x#marshaller#equals y); (* --- Test loading from structure containing itself: *) z#set_field7 (Either.Right x); (* x -> z -> x *) z#set_field5 ([x; z] :> class2 list); (* x -> z -> z *) load_y_with_x (); assert (not (x#marshaller#equals y)); (* because of casting! *) load_y_with_x ~upcasting:() (); assert (x#marshaller#equals y); z#set_field5 ([y; x; z] :> class2 list); (* y is in the graph of x and conversely... *) assert ((y :> class2) = List.hd ((Either.get_right x#get_field7)#get_field5)); load_y_with_x ~upcasting:() (); (* because y in the list of (z of) x was not recognized as... y itself when y was loading: *) assert (not (x#marshaller#equals y)); (* but the first element of the list in y is the old state of y, not the new state obtained loading from x: *) let y'= List.hd ((Either.get_right y#get_field7)#get_field5) in assert (not (y#marshaller#equals y')); (* so, we can try to fix y' in this way: *) let options = make_loading_options ~try_to_preserve_upcasting:() () in y'#marshaller#load_from_string ~options (y#marshaller#save_to_string); (* but y has not the same graph of x: is an equivalent graph where a loop has been expanded: *) assert (not (x#marshaller#equals y)); (* so, we can't restore the broken loop. A solution of this problem could be to define a sigle method saving and loading at same time (instead of doing them sequentially) *) (* --- Test remove_upcasting: *) (* Reloading x and z with themselves, the surplus of methods of their sub-objects will be removed: *) x#marshaller#remake_simplest; assert (not (x#marshaller#equals y)); y#marshaller#remake_simplest; (* Now it's fine: *) assert (x#marshaller#equals y); (* Success: *) Printf.printf "Success.\n"; () ;; end (* module Example *) ENDIF ocamlbricks-0.90+bzr456.orig/MARSHAL/oomarshal.ml0000644000175000017500000001025613175721005020335 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Object-oriented marshalling support. This module contains two distinct marshalling facilities. *) open Marshal;; (** Marshalling flags: we want to support sharing but no closures. *) let flags = [ (* sharing is on by default *) ];; (** {2 An intuitive but unsafe marshalling facility} *) (** The abstract superclass of any marshallable object. Objects can be safely marshalled via methods, but unmarshalling produces results of unconstrained polymorphic types, which must be manually cast by the user. *) (** The virtual marshallable class, which should be the base class of all classes intended for marshalling with this technique. *) class virtual marshallable = object(self) (** Marshal [self] into a string, and return the string *) method to_string = Marshal.to_string self flags (** Marshal [self] into the given channel, and return unit. *) method to_channel c = Marshal.to_channel c self flags (** Marshal [self] into the given file, and return unit. *) method to_file file_name = let channel = open_out file_name in Marshal.to_channel channel self flags; close_out channel end;; (** Unmarshal (what we hope to be) a [marshallable] object from the given string, and return the object with an {e unconstrained polymorphic type}. *) let from_string s = Marshal.from_string s 0;; (** Unmarshal (what we hope to be) a [marshallable] object from the given channel, and return the object with an {e unconstrained polymorphic type}. *) let from_channel c = Marshal.from_channel c;; (** Unmarshal (what we hope to be) a [marshallable] object from the given file, and return the object with an {e unconstrained polymorphic type}. *) let from_file file_name = let channel = open_in file_name in let result = Marshal.from_channel channel in close_in channel; result (** {2 An uglier but safe marshalling facility} This implementation uses casts only internally, but requires the creation of a marshaller object which serves the single purpose of marshalling and unmarshalling the objects it's given, without keeping any internal state; all of this is, put honestly, quite ugly. Marshallers for non-object types are also supported. The marshaller type is correctly inferred. *) (** The marshaller class, instances of which can marshal and unmarshal objects of a given type when requested. *) class ['a] marshaller = object(self) (** Make a new 'a object from the given string, and return it. *) method from_string s = ((Marshal.from_string s 0) :> 'a) (** Make a new 'a object from the given channel, and return it. *) method from_channel c = ((Marshal.from_channel c) :> 'a) (** Make a new 'a object from the given file, and return it. *) method from_file file_name = let channel = open_in file_name in let result = ((Marshal.from_channel channel) :> 'a) in close_in channel; result (** Marshal the given object into the given channel, and return unit. *) method to_channel (x : 'a) c = Marshal.to_channel c x flags (** Marshal the given object into the given file, and return unit. *) method to_file (x : 'a) file_name = let channel = open_out file_name in Marshal.to_channel channel x flags; close_out channel (** Marshal the given object into a new string, and return the string. *) method to_string (x : 'a) = Marshal.to_string x flags end;; (** {3 A small example} {[let m = new marshaller;; print_float (m#from_string (m#to_string 3.2));; ]} *) ocamlbricks-0.90+bzr456.orig/MARSHAL/oomarshal.mli0000644000175000017500000000216713175721005020510 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2007 Luca Saiu This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Object-oriented marshalling support. This module contains two distinct marshalling facilities. *) class ['a] marshaller : object method from_channel : in_channel -> 'a method from_file : string -> 'a method from_string : string -> 'a method to_channel : 'a -> out_channel -> unit method to_file : 'a -> string -> unit method to_string : 'a -> string end ocamlbricks-0.90+bzr456.orig/MARSHAL/marshallable_classes.mli0000644000175000017500000002013713175721005022664 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2012 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Framework to define classes with methods to easily load or save an instance into a string or a file (currently undocumented). The [Camlp4] parser for field's definitions is still not written. Only the run-time support is provided. However, the source code of the module [Example] shows how to define fields manually (without a syntax extension). *) type field_name = string type object_structure type loading_options val make_loading_options : ?mapping:(field_name -> field_name) -> ?mapping_by_list:(field_name * field_name) list -> ?try_to_preserve_upcasting:unit -> ?try_to_reuse_living_objects:unit -> unit -> loading_options (* For protected method: the user may forget them: *) type saving_env type loading_env class marshallable_class : ?name:string -> marshaller:marshaller option ref -> unit -> object method marshaller : marshaller end and marshaller : ?parent_class_name:string -> parent:marshallable_class -> unit -> object method save_to_string : string method save_to_file : string -> unit method load_from_string : ?options:loading_options -> string -> unit method load_from_file : ?options:loading_options -> string -> unit method compare : < marshaller : marshaller; .. > -> int method equals : < marshaller : marshaller; .. > -> bool method md5sum : string method hash32 : int (* 0..(2^30)-1 -- uniform and portable *) (* Reload the object with himself in order to make its components as possible simplest (in other words remove the surplus of components attributes caused by some upcasting operations (:>)) *) method remake_simplest : unit method remove_upcasting : unit (* alias for remake_simplest *) method register_simple_field : ?name:string -> (* the field name *) (unit -> 'a) -> (* the field getter *) ('a -> unit) -> (* the field setter *) unit method register_object_field : 'obj. ?name:string -> (* the field name *) (unit -> (< marshaller : marshaller; .. > as 'obj)) -> (* the object maker (simplest constructor) *) (unit -> 'obj) -> (* the field getter *) ('obj -> unit) -> (* the field setter *) unit method register_functorized_object_field : 'obj 'obj_t 'a 'b 'a_t 'b_t 'ab_t. ?name:string -> (* the field name *) ?zip:('a_t -> 'b_t -> 'ab_t) -> (* functor zip *) (('a -> 'b) -> 'a_t -> 'b_t) -> (* the functor *) (unit -> (< marshaller : marshaller; .. > as 'obj)) -> (* the object maker (simplest constructor) *) (unit -> 'obj_t) -> (* the field getter *) ('obj_t -> unit) -> (* the field setter *) unit method register_bifunctorized_objects_field : 'obj1 'obj2 'objects_t 'a 'b 'c 'd 'ac_t 'bd_t 'au_t 'bv_t 'axb_uxv_t. ?name:string -> (* name *) ?zip:('au_t -> 'bv_t -> 'axb_uxv_t) -> (* zip for bifunctor *) (('a -> 'b) -> ('c -> 'd) -> 'ac_t -> 'bd_t) -> (* bifunctor *) (unit -> (< marshaller : marshaller; .. > as 'obj1)) -> (* object maker 1 (simplest constructor) *) (unit -> (< marshaller : marshaller; .. > as 'obj2)) -> (* object maker 2 (simplest constructor) *) (unit -> 'objects_t) -> (* getter *) ('objects_t -> unit) -> (* setter *) unit method register_trifunctorized_objects_field : 'obj1 'obj2 'obj3 'objects_t 'a 'b 'c 'd 'e 'f 'ace_t 'bdf_t 'aue_t 'bvf_t 'axb_uxv_exf_t . ?name:string -> (* name *) ?zip:('aue_t -> 'bvf_t -> 'axb_uxv_exf_t) -> (* trifunctor zip *) (('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> 'ace_t -> 'bdf_t) -> (* trifunctor *) (unit -> (< marshaller : marshaller; .. > as 'obj1)) -> (* object maker 1 (simplest constructor) *) (unit -> (< marshaller : marshaller; .. > as 'obj2)) -> (* object maker 2 (simplest constructor) *) (unit -> (< marshaller : marshaller; .. > as 'obj3)) -> (* object maker 3 (simplest constructor) *) (unit -> 'objects_t) -> (* getter *) ('objects_t -> unit) -> (* setter *) unit method parent_class_name : string option (* Internal methods (shoud be protected), not for users: *) method protected_load_from_object_structure : loading_env -> object_structure -> unit * loading_env method protected_save_to_object_structure : saving_env -> object_structure * saving_env end val marshallable_classes_version : string val marshallable_classes_metadata : unit -> string val enable_warnings : unit -> unit val disable_warnings : unit -> unit val enable_tracing : unit -> unit val disable_tracing : unit -> unit module Toolkit : sig (* Just an alias for List.combine: *) val zip_list : 'a list -> 'b list -> ('a * 'b) list val zip_array : 'a array -> 'b array -> ('a * 'b) array val zip_option : 'a option -> 'b option -> ('a * 'b) option val zip_either : ('a,'b) Either.t -> ('c,'d) Either.t -> (('a * 'c), ('b * 'd)) Either.t end IFDEF DOCUMENTATION_OR_DEBUGGING THEN module Example : sig class class1 : ?marshaller:marshaller option ref -> unit -> object method get_field0 : int method set_field0 : int -> unit method get_field1 : string method set_field1 : string -> unit method get_field2 : int option method set_field2 : int option -> unit method marshaller : marshaller end class class2 : ?marshaller:marshaller option ref -> unit -> object method get_field0 : int method set_field0 : int -> unit method get_field1 : string method set_field1 : string -> unit method get_field2 : int option method set_field2 : int option -> unit method get_field3 : class1 method set_field3 : class1 -> unit method get_field4 : class2 option method set_field4 : class2 option -> unit method get_field5 : class2 list method set_field5 : class2 list -> unit method marshaller : marshaller end class class3 : ?marshaller:marshaller option ref -> unit -> object method get_field0 : int method set_field0 : int -> unit method get_field1 : string method set_field1 : string -> unit method get_field2 : int option method set_field2 : int option -> unit method get_field3 : class1 method set_field3 : class1 -> unit method get_field4 : class2 option method set_field4 : class2 option -> unit method get_field5 : class2 list method set_field5 : class2 list -> unit method get_field6 : char method set_field6 : char -> unit method get_field7 : (class2, class3) Either.t method set_field7 : (class2, class3) Either.t -> unit method marshaller : marshaller end val crash_test : unit -> unit end ENDIF ocamlbricks-0.90+bzr456.orig/CORTEX/0000755000175000017500000000000013175721005015727 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/CORTEX/lock.mli0000644000175000017500000000760113175721005017366 0ustar lucaslucas(* ------------------------------------- * Very low-level access * ------------------------------------- *) module Basic : sig (* --- *) type b = Mutex.t * Condition.t (* --- *) val create : unit -> b val try_lock : ?guard:(b -> bool) -> b -> bool val lock : ?guard:(b -> bool) -> ?timeout:float -> b -> unit val wait : b -> unit val signal : b -> unit val broadcast : b -> unit val unlock : b -> unit (* --- *) val merge_and_sort_basic_lists : (b list) list -> b list val compare : b -> b -> int end (* Conjunction: a sorted array of basic locks: *) module Conjunction : sig (* --- *) type c = b array and b = Basic.b (* --- *) val create : unit -> c val product : c list -> c val unity : c (* empty*) val append : c -> c -> c (* a binary product without reordering *) val try_lock : ?guard:(c -> bool) -> c -> bool val lock : ?guard:(c -> bool) -> ?timeout:float -> c -> unit val unlock : c -> unit val wait : c -> b option (* the result is the basic where something has happen, if any *) val broadcast : c -> unit (* --- *) val compare : c -> c -> int module Set : Set.S with type elt = c end (* ------------------------------------- * Low-level access * ------------------------------------- *) (* The module in a nutshell: *) type b = Basic.b (* Basic locks : b = (mutex, condition) *) and c = Conjunction.c (* Ordered conjunctions of basic locks : c = b1 ⋅ b2 ⋅ ⋅⋅⋅ ⋅ bk *) and d = Conjunction.c array (* Disjunction of conjunctions : d = c1 + c2 + ... + cn *) (* Alias that helps to clarify the signature of try_lock: *) type 'a maybe = 'a option exception Timeout (* The result of try_lock should be interpreted in this way: None => false, Some(None) => true but the disjunction is empty (zero), Some(Some(c)) => true with the involved conjunction c. *) val try_lock : ?guard:(c -> bool) -> d -> c option maybe (* The result of lock() is None iff the disjunction is empty *) val lock : ?guard:(c -> bool) -> ?timeout:float -> d -> c option val wait : c -> b option (* the result is the basic where something has happen, if any *) val broadcast : c -> unit (* alert *) val unlock : c -> unit (* ------------------------------------- * High-level access * ------------------------------------- *) (* A lock, in the more general sense, is a disjunction: *) type t = d val create : unit -> t val sum : t list -> t (* general n-ary sum of locks *) val product : t list -> t (* general n-ary product of locks *) val zero : t (* identity element of the sum: 0 = {} *) val unity : t (* identity element of the product: 1 = {{}} *) val empty : t (* alias for zero *) val of_conjunction_list : Conjunction.c list -> d val of_conjunction_array : Conjunction.c array -> d (* Should we alert other threads waiting on this structure? In other terms, should we perform a broadcast? *) type alert = bool (* A "trailer" is an optional thunk executed out of the critical section, that is to say after unlocking the structure. *) type trailer = (unit -> unit) option (* High-level blocking access. The second result of the action (c -> 'a * alert) indicates if a broadcast must be performed on the locked conjunction, before unlocking. Both the function `guard' and the action (c -> 'a * alert) take a conjunction as argument. The idea is that, with this information (used as a dictionary key), all these functions could recover other related informations. *) val access : ?verbose:unit -> ?guard:(c -> bool) -> ?timeout:float -> t -> (c -> 'a * alert * trailer) -> 'a (* High-level non-blocking access. *) val try_access : ?verbose:unit -> ?guard:(c -> bool) -> t -> (c -> 'a * alert * trailer) -> 'a option ocamlbricks-0.90+bzr456.orig/CORTEX/locked.mli0000644000175000017500000000754313175721005017704 0ustar lucaslucas (* The principal type of this module is a disjunction of locked values: *) type 'a t = 'a d (* --- *) and 'a d = ('a c) array and 'a c = Lock.c * 'a and 'a locked = ('a c) option (* the actual locked value, if any (i.e. iff the disjunction is not empty) *) (* Constructors: *) (* The preferable way to make locked values is to convert a fresh values constructor into a locked values one. This method prevent the user to access values without locking them. *) val constructor : ('a -> 'b) -> 'a -> 'b d val return : 'a -> 'a d (* make a structure protected by a basic lock (mutex) *) val make : 'a -> 'a d (* alias for return *) (* --- *) val empty : 'a d (* alias for zero *) val fictive : 'a -> 'a d (* alias for unity *) (* Algebraic operations (sum and product): *) val zero : 'a d (* identity element of the sum (the empty set of conjunctions) *) val unity : 'a -> 'a d (* make a not really protected structure (i.e. protected by the empty set of conjunctions...) *) (* Homogeneous variadic sum: *) val sum : ('a d) list -> 'a d (* Homogeneous variadic product: *) val product : ('a d) list -> ('a list) d (* Eterogeneous n-ary products: *) val product2 : ('a d) -> ('b d) -> ('a * 'b) d val product3 : ('a d) -> ('b d) -> ('c d) -> ('a * 'b * 'c) d val product4 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('a * 'b * 'c * 'd) d val product5 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('e d) -> ('a * 'b * 'c * 'd * 'e) d (* Homogeneous compositional variadic product: *) val cproduct : ('a d) list -> ('a list -> 'alist) -> ('alist) d (* Eterogeneous compositional n-ary products: *) val cproduct2 : ('a d) -> ('b d) -> ('a -> 'b -> 'ab) -> ('ab) d val cproduct3 : ('a d) -> ('b d) -> ('c d) -> ('a -> 'b -> 'c -> 'abc) -> ('abc) d val cproduct4 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('a -> 'b -> 'c -> 'd -> 'abcd) -> ('abcd) d val cproduct5 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('e d) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'abcde) -> ('abcde) d (* High level access: *) (* Should we alert other threads waiting on this structure? In other terms, should we perform a broadcast? *) type alert = bool (* A "trailer" is an optional thunk executed out of the critical section, that is to say after unlocking the structure. *) type trailer = (unit -> unit) option (* High-level blocking access. An action of type ('a -> 'b * alert) is performed on the locked structure of type 'a, which is usually mutable (for instance a reference or an object). So, this action may change implicitely the internal state of its argument (of type 'a) to produce an output (of type 'b). If this happens, the action notify that a broadcast must be performed through the second (boolean) part of its result (alert). --- The trailer is not necessary but very practical because the action usually decides all the next steps: (1) which is the provided result (2) is an alert required? (3) are some final actions required (out of critical section)? *) val access : ?verbose:unit -> ?guard:('a -> bool) -> ?timeout:float -> 'a t -> ('a -> 'b * alert * trailer) -> 'b (* High-level non-blocking access: *) val try_access : ?verbose:unit -> ?guard:('a -> bool) -> 'a t -> ('a -> 'b * alert * trailer) -> 'b option (* Simplified interfaces for access and try_access: *) val easy_access : 'a t -> ('a -> 'b) -> 'b val easy_try_access : 'a t -> ('a -> 'b) -> 'b option (* Low level access: *) val try_lock : ?guard:('a -> bool) -> 'a d -> ('a locked) option val lock : ?guard:('a -> bool) -> ?timeout:float -> 'a d -> 'a locked val wait : 'a locked -> Lock.b option (* the result is the basic lock where something has happen, if any *) val broadcast : 'a locked -> unit (* alert the involved conjunction *) val unlock : 'a locked -> unit (* unlock the involved conjunction *) val involved_locks : 'a locked -> Lock.b array ocamlbricks-0.90+bzr456.orig/CORTEX/spinning.mli0000644000175000017500000001402313175721005020257 0ustar lucaslucas(** A simple module for active waiting ("spinning" or "busy-waiting"). This is the only possibility when a value is not locked by a mutex or when is locked by a mutex unrelated to a condition variable. *) (** Type aliases: *) type time = seconds and delay = seconds and seconds = float exception Timeout (* ======================================================== Simplified interface ======================================================== *) type 'a thunk = unit -> 'a (** Wait until a condition (guard) becames true, applying a function "delay" to sleep between two tests. The backoff function used to build the delay function is linear by default. A couple of thunks for unlocking/relocking may be provided to be executed before and after sleeping. The result is the value returned by the last relocking call, or it is the provided one if the relocking was never been called. Note that the type 'a became simply "unit" if the locking (relock) function doesn't return a meaningfull information, which is the common case. May raise Timeout if ?timeout is provided. *) val wait_until : ?backoff:[`linear|`exponential|`binary_exponential] -> ?max_delay:time -> ?slot:time -> unit -> (* constructor *) ?unlock_relock:(unit thunk * 'a thunk) -> ?timeout_exn:exn -> (* exception to be raised in case of timeout (by default is Spinning.Timeout) *) ?timeout:seconds -> guard:(unit->bool) -> 'a -> 'a (* usually unit->unit *) (** As the previous function with two differences: (1) the argument ~timeout is mandatory, and (2) when the timeout occurs, it doesn't raise the exception Timeout (just returns None). *) val wait_impatiently : ?backoff:[`linear|`exponential|`binary_exponential] -> ?max_delay:time -> ?slot:time -> unit -> (* constructor *) ?unlock_relock:(unit thunk * 'a thunk) -> ?timeout_exn:exn -> timeout:seconds -> guard:(unit->bool) -> 'a -> 'a option (* usually unit->(unit option) *) (* ======================================================== Full detailed interface ======================================================== *) (** A backoff_function takes the number of observed collisions c and returns the range r from which to extract a random number k (in the interval [0..r]). This factor, multiplied to the "slot_time" d, determines the time (d*k) to sleep (i.e. the "delay") before a new evaluation of a condition. --- Exemples of backoff functions: Linear (c->c), Binary exponential (c->2^c), Truncated binary exponential (c->2^(min c max_collisions),.. *) module Backoff : sig (* --- *) type f = collisions -> delay_range (* --- *) and collisions = float and delay_range = time (* --- *) (* Common cases: *) val linear : f (* fun c->c *) val exponential : f (* exp *) val binary_exponential : f (* fun c->2.**c *) (* --- *) (* Used by Ethernet CSMA/CD: we define a maximum number of collisions (max{x}) instead of a max range (~max_delay, i.e. max{f(x)}): *) val truncated_binary_exponential : ?max_collisions:int -> f (* fun c->2.**(min c max_collisions) *) (* --- *) end (* Backoff *) (** Default for functions taking these optional arguments. *) module Default : sig (* --- *) val backoff : Backoff.f (* Backoff.linear *) val slot : time (* 0.1 seconds *) (* --- *) end (* Random generators, built from common backoff functions: *) module Random : sig (* --- *) type g = unit -> delay (* --- *) val make : ?max_delay:time -> ?slot:time -> ?backoff:Backoff.f -> unit -> g (* --- *) (* Common cases: *) val linear : ?max_delay:time -> ?slot:time -> unit -> g val exponential : ?max_delay:time -> ?slot:time -> unit -> g val binary_exponential : ?max_delay:time -> ?slot:time -> unit -> g val truncated_binary_exponential : ?max_collisions:int -> ?slot:time -> unit -> g (* Ethernet CSMA/CD *) (* --- *) end (* Random *) (** A "delay" is a function that sleeps (applying Thread.sleep) during a random time in an evolving range (possibly limited by ~max_delay) *) module Delay : sig (* --- *) type p = unit -> unit (* procedure *) (* --- *) val make : ?max_delay:time -> ?slot:time -> Backoff.f -> p (* --- *) (* Common cases: *) val linear : ?max_delay:time -> ?slot:time -> unit -> p val exponential : ?max_delay:time -> ?slot:time -> unit -> p val binary_exponential : ?max_delay:time -> ?slot:time -> unit -> p val truncated_binary_exponential : ?max_collisions:int -> ?slot:time -> unit -> p (* Ethernet CSMA/CD *) (* --- *) end (* Delay *) (** A "wait_until" is a kind of function that waits until a condition becames true, applying a function "delay" to sleep between two tests. A couple of thunks for unlocking/relocking may be provided to be executed before and after sleeping. The result of a function is the value returned by the last relocking call, or it's the provided one (identity) if the relocking has never been called. *) module Wait_until : sig (* --- *) (* ?timeout_exn is the exception to be raised in case of timeout (by default is Spinning.Timeout) *) (* 'lock will be simply "unit" if the locking (relock) function doesn't return a meaningfull information: *) type 'lock f = ?unlock_relock:(unit thunk * 'lock thunk) -> ?timeout_exn:exn -> ?timeout:seconds -> guard:(unit->bool) -> 'lock -> 'lock (* --- *) and 'a thunk = unit -> 'a (* --- *) val make : ?max_delay:time -> ?slot:time -> Backoff.f -> 'lock f (* --- *) val linear : ?max_delay:time -> ?slot:time -> unit -> 'lock f val exponential : ?max_delay:time -> ?slot:time -> unit -> 'lock f val binary_exponential : ?max_delay:time -> ?slot:time -> unit -> 'lock f val truncated_binary_exponential : ?max_collisions:int -> ?slot:time -> unit -> 'lock f (* Ethernet CSMA/CD *) (* --- *) end (* Wait_until *) ocamlbricks-0.90+bzr456.orig/CORTEX/spinning.ml0000644000175000017500000002155213175721005020113 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013, 2014, 2015, 2016, 2017 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (** Type aliases: *) type time = seconds and delay = seconds and seconds = float exception Timeout let coverup f x y = try f x with _ -> y let flipped_coverup f y x = try f x with _ -> y module Backoff = struct type f = collisions -> delay_range (* --- *) and collisions = float and delay_range = float let linear = (fun c->c) let exponential = (exp) let binary_exponential = (fun c->2.**c) (* Used by Ethernet CSMA/CD: we define a maximum number of collisions (max{x}) instead of a max range (~max_delay, i.e. max{f(x)}): *) let truncated_binary_exponential ?(max_collisions=10) = let max_collisions = float_of_int max_collisions in fun c -> 2.**(min c max_collisions) end (* Backoff *) (** Default for functions taking these optional arguments. *) module Default = struct let backoff = Backoff.linear let slot = 0.1 (* 0.1 seconds *) end (* Random generators, built from common backoff functions: *) module Random = struct type g = unit -> delay (* --- *) let make ?(slot = Default.slot) ?(backoff = Default.backoff) () : g = let c = ref 0 in (* number of collisions, in the closure *) fun () -> let range = abs_float (backoff (float_of_int !c)) in let time = slot *. (Random.float range) in let () = incr c in time let make_with_truncated_range ~max_delay ?(slot = Default.slot) ?(backoff = Default.backoff) () : g = let c = ref 0 in (* number of collisions, in the closure *) let max_joined = ref false in fun () -> let range = match !max_joined with | false -> let result = abs_float (backoff (float_of_int !c)) in if (result > max_delay) then (max_joined := true; max_delay) else (incr c; result) (*--- *) | true -> max_delay in let time = slot *. (Random.float range) in time (* make redefined with ?max_delay *) (* val make : ?max_delay:time -> ?slot:time -> ?backoff:Backoff.f -> unit -> g *) let make ?max_delay = match max_delay with None -> make | Some max_delay -> make_with_truncated_range ~max_delay (* Common cases: *) let linear ?max_delay ?slot () = make ?max_delay ?slot ~backoff:Backoff.linear () let exponential ?max_delay ?slot () = make ?max_delay ?slot ~backoff:Backoff.exponential () let binary_exponential ?max_delay ?slot () = make ?max_delay ?slot ~backoff:Backoff.binary_exponential () (* Used by Ethernet CSMA/CD: we define a maximum number of collisions (max{x}) instead of a max range (~max_delay, i.e. max{f(x)}): *) let truncated_binary_exponential ?(max_collisions=10) ?slot () = let max_collisions = float_of_int max_collisions in make ?slot ~backoff:(fun c->2.**(min c max_collisions)) () end (* Random *) (* A "delay" is a function that sleeps (applying Thread.sleep) during a random time in an evolving range (possibly limited by ~max_delay) *) module Delay = struct type p = unit -> unit (* "p" for procedure *) let make ?max_delay ?slot (backoff) : p = let random = Random.make ?max_delay ?slot ~backoff () in fun () -> Thread.delay (random ()) let linear ?max_delay ?slot () : p = let random = Random.linear ?max_delay ?slot () in fun () -> Thread.delay (random ()) let exponential ?max_delay ?slot () : p = let random = Random.exponential ?max_delay ?slot () in fun () -> Thread.delay (random ()) let binary_exponential ?max_delay ?slot () : p = let random = Random.binary_exponential ?max_delay ?slot () in fun () -> Thread.delay (random ()) let truncated_binary_exponential ?max_collisions ?slot () : p = let random = Random.truncated_binary_exponential ?max_collisions ?slot () in fun () -> Thread.delay (random ()) end (* Delay *) (* guard is a "remain" condition: *) let loop_while guard f = let rec loop token = if guard () then loop (f token) else token in loop (* guard is an "exit" condition: *) let loop_while_not guard f = let rec loop token = if guard () then token else loop (f token) in loop (* A "wait_until" is a kind of function that waits until a condition becames true, applying a function "delay" to sleep between two tests. A couple of thunks for unlocking/relocking may be provided to be executed before and after sleeping. *) module Wait_until = struct (* 'lock will be simply "unit" if the locking (relock) procedure doesn't return a meaningfull information: *) type 'lock f = ?unlock_relock:(unit thunk * 'lock thunk) -> ?timeout_exn:exn -> ?timeout:seconds -> guard:(unit->bool) -> 'lock -> 'lock and 'a thunk = unit -> 'a let wait_until ?unlock_relock ?(timeout_exn=Timeout) ?timeout (guard) (delay) (token:'lock) : 'lock = match unlock_relock, timeout with (* --- *) | None, None -> let () = while not (coverup guard () false) do delay () done in token (* --- *) | None, Some timeout -> let starting_time = Unix.gettimeofday () in let () = while not (coverup guard () false) do (if ((Unix.gettimeofday ()) -. starting_time) > timeout then raise timeout_exn); delay () done in token (* --- *) | Some (unlock, relock), None -> (* val loop_until : (unit -> bool) -> ('a -> 'a) -> 'a -> unit *) loop_while_not (flipped_coverup guard false) (fun _ -> unlock(); delay(); relock ()) (token) (* --- *) | Some (unlock, relock), Some timeout -> let starting_time = Unix.gettimeofday () in (* val loop_while_not : (unit -> bool) -> ('a -> 'a) -> 'a -> unit *) loop_while_not (flipped_coverup guard false) (fun _ -> unlock(); (if ((Unix.gettimeofday ()) -. starting_time) > timeout then raise timeout_exn); delay(); relock ()) (token) let make ?max_delay ?slot (backoff_function) : 'lock f = fun ?unlock_relock ?timeout_exn ?timeout ~guard token -> let delay = Delay.make ?max_delay ?slot (backoff_function) in wait_until ?timeout_exn ?timeout ?unlock_relock (guard) (delay) (token) let linear ?max_delay ?slot () : 'lock f = fun ?unlock_relock ?timeout_exn ?timeout ~guard token -> let delay = Delay.linear ?max_delay ?slot () in wait_until ?timeout_exn ?timeout ?unlock_relock (guard) (delay) (token) let exponential ?max_delay ?slot () : 'lock f = fun ?unlock_relock ?timeout_exn ?timeout ~guard token -> let delay = Delay.exponential ?max_delay ?slot () in wait_until ?timeout_exn ?timeout ?unlock_relock (guard) (delay) (token) let binary_exponential ?max_delay ?slot () : 'lock f = fun ?unlock_relock ?timeout_exn ?timeout ~guard token -> let delay = Delay.binary_exponential ?max_delay ?slot () in wait_until ?timeout_exn ?timeout ?unlock_relock (guard) (delay) (token) let truncated_binary_exponential ?max_collisions ?slot () : 'lock f = fun ?unlock_relock ?timeout_exn ?timeout ~guard token -> let delay = Delay.truncated_binary_exponential ?max_collisions ?slot () in wait_until ?timeout_exn ?timeout ?unlock_relock (guard) (delay) (token) end (* Wait_until *) (* Simplified interface: *) type 'a thunk = unit -> 'a let wait_until ?(backoff=`linear) = match backoff with | `linear -> Wait_until.linear | `exponential -> Wait_until.exponential | `binary_exponential -> Wait_until.binary_exponential (* Auxiliary type: *) type 'a wait_until_signature = ?unlock_relock:(unit thunk * 'a thunk) -> ?timeout_exn:exn -> ?timeout:seconds -> guard:(unit->bool) -> 'a -> 'a let wait_impatiently ?(backoff=`linear) ?max_delay ?slot () = let launch (wait_until:'a wait_until_signature) ?unlock_relock ?timeout_exn ~timeout ~guard x = try Some (wait_until ?unlock_relock ?timeout_exn ~timeout ~guard x) with Timeout -> None in match backoff with | `linear -> let w = Wait_until.linear ?max_delay ?slot () in launch w | `exponential -> let w = Wait_until.linear ?max_delay ?slot () in launch w | `binary_exponential -> let w = Wait_until.linear ?max_delay ?slot () in launch w ocamlbricks-0.90+bzr456.orig/CORTEX/lock.ml0000644000175000017500000006044613175721005017223 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2013, 2014, 2015, 2016, 2017 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) (* The module in a nutshell: (* --- *) type b = Mutex.t * Condition.t (* basic locks *) and c = b list (* conjunction: an ordered list of basic locks *) and d = c list (* disjunction: a set of conjunctions *) and t = d (* a lock is a disjunction *) (* --- *) *) (** Generic functor to manage (S)et (U)nique sorted lists, i.e. sorted lists without duplicated. *) module SUList_of_Set = functor (S:Set.S) -> struct include S type l = elt list let concat (xss : l list) : l = let r = List.fold_left (fun r xs -> S.union r (S.of_list xs)) (S.empty) xss in S.elements r let make (xs : elt list) : l = S.elements (of_list xs) let make_from_array (xs : elt array) : l = S.elements (Array.fold_left (fun m e -> S.add e m) S.empty xs) let private_map_cartesian_product (f : elt -> elt -> elt) (t1:t) (l2:l) : t = let t2 = of_list l2 in let assoc_to_all (x:elt) (ys:t) : t = S.fold (fun y xys -> S.add (f x y) xys) ys (S.empty) in S.fold (fun x r -> S.union r (assoc_to_all x t2)) t1 (S.empty) let map_cartesian_product (f : elt -> elt -> elt) (l1:l) (l2:l) : t = let t1 = of_list l1 in private_map_cartesian_product f t1 l2 (* Exemple: SUList.map_n_fold_cartesian_product (fun x y -> x*y) [[0;1;2]; [3;5]; [10; 100; 1000]];; : SUList.l = [0; 30; 50; 60; 100; 300; 500; 600; 1000; 3000; 5000; 6000; 10000] *) let map_n_fold_cartesian_product (f : elt -> elt -> elt) : (l list -> l) = function | [] -> [] | l::ls -> let t = List.fold_left (private_map_cartesian_product f) (of_list l) ls in S.elements t end (* SUList_of_Set() *) module SUList_of_Ord = functor (Ord:Set.OrderedType) -> SUList_of_Set (Set.Make (Ord)) (* Example: module Int_SUList = SUList_of_Ord (struct type t = int let compare = compare end) *) exception Timeout let coverup f x y = try f x with _ -> y (* From ArrayExtra: *) let array_find p s = let l = Array.length s in let rec loop i = if i>=l then raise Not_found else let x = s.(i) in if (p x) then x else loop (i+1) in loop 0 (* Basic locks: *) module Basic : sig (* --- *) type b = Mutex.t * Condition.t (* --- *) val create : unit -> b val try_lock : ?guard:(b -> bool) -> b -> bool val lock : ?guard:(b -> bool) -> ?timeout:float -> b -> unit val wait : b -> unit val signal : b -> unit val broadcast : b -> unit val unlock : b -> unit (* --- *) val merge_and_sort_basic_lists : (b list) list -> b list val compare : b -> b -> int end = struct type b = Mutex.t * Condition.t let create () : b = (Mutex.create (), (Condition.create ())) let compare (m0,v0) (m1,v1) = compare m0 m1 module Set = Set.Make (struct type t = b let compare = compare end) let merge_and_sort_basic_lists (bss : b list list) : b list = let add s l = List.fold_left (fun s x -> Set.add x s) s l in let s = List.fold_left (add) Set.empty bss in Set.elements s let wait (m,v) = Condition.wait v m let broadcast (m,v) = Condition.broadcast v let signal (m,v) = Condition.signal v let unlock (m,v) = Mutex.unlock m let try_lock ?guard ((m,v) as b) = (Mutex.try_lock m) && (match guard with | None -> true | Some guard -> if (coverup guard b false) then true (* fine, the mutex is locked and the guard is true. It's a success (return true) *) else begin (* but if the guard is false, unlock the mutex and fail (return false) *) Mutex.unlock m; false end) (* The timeout concerns the time to wait for the guard (not for getting the lock): *) let lock ?guard ?timeout ((m,v) as b) = begin let starting_time = if (guard = None) || (timeout = None) then 0. else Unix.gettimeofday () in Mutex.lock m; match guard, timeout with | None, _ -> () | (Some guard), None -> while not (coverup guard b false) do Condition.wait v m done | (Some guard), (Some timeout) -> while not (coverup guard b false) do (if ((Unix.gettimeofday ()) -. starting_time) > timeout then (Mutex.unlock m; raise Timeout)); Condition.wait v m done end end (* Basic *) (* Alias: *) type b = Basic.b (* Conjunction: a sorted array of basic locks: *) module Conjunction : sig (* --- *) type c = b array and b = Basic.b (* --- *) val create : unit -> c val product : c list -> c val unity : c (* empty*) val append : c -> c -> c (* a binary product without reordering *) val try_lock : ?guard:(c -> bool) -> c -> bool val lock : ?guard:(c -> bool) -> ?timeout:float -> c -> unit val unlock : c -> unit val wait : c -> b option (* the result is the basic where something has happen, if any *) val broadcast : c -> unit (* --- *) val compare : c -> c -> int module Set : Set.S with type elt = c end = struct type c = b array and b = Basic.b let create () = Array.make 1 (Basic.create ()) let unity : c = [||] let product cs = let bs = let bss = List.map (Array.to_list) cs in Basic.merge_and_sort_basic_lists bss in Array.of_list bs (* This is the same of the product, but the second list is forced to be at the end of the first: *) let append = Array.append (* Something happens for c if something happens somewhere in c. *) let wait c = begin match Array.length c with | 0 -> None | 1 -> let () = Basic.wait c.(0) in (Some c.(0)) (* Simple case: the conjunction is a singleton *) | n -> (* This is the complicated case: c is composed by several basic components. We will start a thread per component, waiting for an event on this component. *) let egg_lock = Basic.create () in let egg = ref None in (* protected by the egg_lock *) let first_i = ref 0 in (* protected by the egg_lock, this represents the first index that can remain locked *) (* --- *) (* A thread takes a triple (i,b,x) where b is a basic lock, i is its index and x is a reference on which the thread notifies its termination: *) let thread_behaviour (i, b, x) : unit = begin Basic.wait b; (* wait on the basic component *) (* --- *) Basic.lock egg_lock; (* BEGIN --- egg_lock protect both egg and x *) (if (!egg) = None then (egg := Some b)); (* the first awakened is the winner *) x := true; (* I'm terminated *) let unlock_b = if (i = !first_i) (* slight optimization: while the wait calls *) then ((incr first_i); false) (* exit (relock) in the correct order, dont unlock *) else true in Basic.signal egg_lock; (* signal the father on egg_lock (broadcast would do the same job) *) Basic.unlock egg_lock; (* END --- *) (* --- *) (* Important point: unlock b (except if b is the first lock, because we have to relock the mutexes in the correct order): *) if (unlock_b) then Basic.unlock b; end (* --- *) in (* Basic components as simple list: *) let bs = Array.to_list c in (* The father get the egg_lock before to spawn its children: *) Basic.lock egg_lock; (* Spawn all threads: *) let txbs : (Thread.t * (bool ref) * Basic.b) list = List.mapi (fun i b -> let x = ref false in (* here x means terminated *) let t = Thread.create thread_behaviour (i, b, x) in (t,x,b)) bs in (* Now wait for the egg (the basic lock awaked by the context): *) Basic.wait egg_lock; (* --- *) (* Broadcast all living threads waiting on a basic lock, in order to force them to interrupt their waiting to get their lock again. Note that this behaviour generates a kind of "false alarm" for other threads that operate on a structure having an intersection with this conjunction, even if they aren't concerned by the occurred event. Quite ugly but unavoidable at this level. To solve this problem, we should have a variant of the OS call system signal() allowing to specify a thread id as destination (instead to have only the choice between signal, i.e. one destination, and broadcast(), i.e. all destionations). *) let living = ref (List.filter (fun (t,x,b) -> not (!x)) txbs) in (* --- *) while (!living) <> [] do List.iter (fun (t,x,b) -> Basic.broadcast b) (!living); Basic.wait egg_lock; living := (List.filter (fun (t,x,b) -> not (!x)) (!living)); done; (* --- *) (* Now wait the end of all threads in order to be sure that all mutexes have been re-locked: *) let () = List.iter (fun (t,x,b) -> Thread.join t) txbs in (* unnecessary (redundant) *) (* --- *) (* At this point, only the first mutexes are locked (in the worst case only the mutex 0 is locked, the rest has been unlocked). We have now to lock again the rest of mutexes forcing the correct order: *) let () = for i = !first_i (* not zero *) to (n-1) do Basic.lock c.(i) done in (* --- *) !egg end (* The broadcast is performed backward (just a choice): *) let broadcast c = let last = (Array.length c) - 1 in for i = last downto 0 do Basic.broadcast c.(i); done (* The unlock *must* be performed backward, i.e. in the reversed order: *) let unlock c = let last = (Array.length c) - 1 in for i = last downto 0 do Basic.unlock c.(i); done (* If the conjunction is empty, there are two cases according to the presence of the optional argument `guard'. If the guard is provided, "lock with a guard" just means "wait for the guard". if the guard is not provided, the lock operation is meaningless. *) let lock ?guard ?timeout c = match (Array.length c) with (* --- *) | 0 -> begin match guard with | None -> () (* lock is meaningless *) | Some guard -> (* lock means wait (i.e. wait without unlocking-relocking, because there aren't locks!) *) (* --- *) (* Initialize a wait function that reiterates the tests sleeping an increasing random, amount of time between two tests: *) let wait_until = Spinning.Wait_until.linear ~max_delay:3. () in (* linear increasing of random delays *) wait_until ~timeout_exn:Timeout ?timeout ~guard:(fun () -> guard c) () end (* --- *) | n -> begin (* The conjunction is not empty: *) let starting_time = if (guard = None) || (timeout = None) then 0. else Unix.gettimeofday () in let last = (n-1) in for i = 0 to last do let (m,v) = c.(i) in Mutex.lock m; done; (* lock in the correct order *) match guard, timeout with | None,_ -> () (* if there is no guard, that's all *) (* --- *) | (Some guard), None -> while not (coverup guard c false) do ignore (wait c) (* ignore the basic lock involved by an alert (signal or broadcast) *) done (* --- *) | (Some guard), (Some timeout) -> while not (coverup guard c false) do (if ((Unix.gettimeofday ()) -. starting_time) > timeout then (unlock c; raise Timeout)); ignore (wait c) (* ignore the basic lock involved by an alert (signal or broadcast) *) done end let try_lock ?guard c = match (Array.length c) with (* --- *) | 0 -> (match guard with | None -> true | Some guard -> coverup guard c false (* just once, not in a loop! *) ) (* --- *) | n -> begin (* The conjunction is not empty: *) (* --- *) (* This function tries to lock the list of mutexes, returning the acquired mutexes in any case: *) let rec loop acc i = if (i = n) then (true, acc) else (* continue: *) let (m,v) = c.(i) in if Mutex.try_lock m then loop (m::acc) (i+1) else (false, acc) in (* --- *) match loop [] 0 with | (false, rev_ms) -> begin (* Important point: unlock mutexes locked uselessly! *) List.iter (Mutex.unlock) rev_ms; false end (* --- *) | (true, rev_ms) -> (* All mutexes are locked, but this may be not sufficient: *) (match guard with | None -> true | Some guard -> if (coverup guard c false) then true (* fine, all mutexes are locked and the guard is true. It's a success (return true) *) else begin (* but if the guard is false, unlock all the mutexes and fail (return false) *) List.iter (Mutex.unlock) rev_ms; false end) end (* try_lock *) (* Lexicographic extensions of `compare' for arrays: *) let compare_array ~(compare:'a->'a->int) = fun xs ys -> let n = Array.length xs in let m = Array.length ys in let rec loop i = if i=n && i=m then 0 else if i=n && i d (* --- *) val of_conjunction_list : c list -> d val of_conjunction_array : c array -> d (* removes duplicated *) (* --- *) val zero : d (* identity element of the sum *) val sum : d list -> d (* --- *) val unity : d (* identity element of the product *) val product : d list -> d (* --- *) val try_lock : ?guard:(c -> bool) -> d -> c option option val lock : ?guard:(c -> bool) -> ?timeout:float -> d -> c option (* The result is None iff the disjunction is empty *) end = struct type d = c array let create () = Array.make 1 (Conjunction.create ()) module Conjunction_list = SUList_of_Ord (struct type t = c let compare = Conjunction.compare end) let zero = [||] let unity = [| Conjunction.unity |] (* the "unity" is the singleton containing the empty conjunction *) (* n-ary sum. The meaning is: (c1 + c2) + c3 = (c1 + c2 + c3) *) let sum (ds : d list) : d = Array.of_list (Conjunction_list.concat (List.map Array.to_list ds)) let of_conjunction_list (cs : c list) : d = Array.of_list (Conjunction_list.make cs) let of_conjunction_array (cs : c array) : d = Array.of_list (Conjunction_list.make_from_array cs) (* n-ary product. The meaning is: (c1 + c2) ⋅ (c3 + c4 + c5) = (c1⋅c3 + c1⋅c4 + c1⋅c5 + c2⋅c3 + c2⋅c4 + c2⋅c5) *) let product (ds : d list) : d = if ds = [] then unity else (* continue: *) let conj_prod x y = Conjunction.product [x;y] in let result = Conjunction_list.map_n_fold_cartesian_product (conj_prod) (List.map Array.to_list ds) in Array.of_list result type 'a maybe = 'a option (* In a disjunctive setting, try_lock return the choosen and locked conjunction, if any. *) let try_lock ?guard d : c option maybe = if (Array.length d) = 0 then Some None else try Some(Some(array_find (Conjunction.try_lock ?guard) d)) with Not_found -> None (* In a disjunctive setting, the lock is a function that returns the choosen (and locked) conjunction. *) let lock ?guard ?timeout (d:d) : c option = match Array.length d with | 1 -> let () = Conjunction.lock ?guard ?timeout d.(0) in Some d.(0) (* Usual case: the disjunction is a singleton *) | 0 -> None | n when (guard = None) -> begin (* When there's not a guard and there's not an immediately free conjunction (try_lock), our simple and perfectible policy is to choose randomly the conjunction to lock. *) match try_lock d with (* try to avoid the random method *) | Some result -> result (* bingo! *) | None -> (* Choose randomly: *) let i = Random.int n in let () = Conjunction.lock d.(i) in Some d.(i) end | n -> match try_lock ?guard d with (* try to avoid the general but heavy method *) | Some result -> result (* bingo! *) | None -> (* General (heavy) method involving a thread per basic lock of the conjunction: *) begin (* All conjunctions are busy or not eligible (guard), so we have to start some parallel threads, sharing an "egg": *) let egg_lock = Conjunction.create () in (* it's a unitary conjunction, in other terms a basic lock *) let egg = ref None in (* protected by the egg_lock *) (* --- *) (* Append the egg_lock to all conjunctions (in the last position): *) let cs = Array.to_list d in let cc's = List.map (fun c -> (c, Conjunction.append c egg_lock)) cs in (* --- *) let guard = match guard with | None -> (fun c -> true) (* no guard, never wait *) | Some g -> (fun c -> ((!egg) <> None) || (coverup g c false)) (* don't wait if the egg has been released *) in (* --- *) (* Note here that c' is the product (c ⋅ egg_lock). The parameter x is a reference on which the thread notifies its termination: *) let thread_behaviour (c,c',x) : unit = begin try (* Locking c' we lock also the egg (but the boolean guard is on c). In this way, the waiting is also on c', in order to unlock-relock also the egg_lock: *) Conjunction.lock ~guard:(fun _ -> guard c) ?timeout c'; (* --- *) (* After locking c' (containing the egg_lock): *) x := true; (* I'm terminated *) Conjunction.broadcast egg_lock; (* signal the father and brothers on egg_lock *) (* --- *) if (!egg) = None then begin (egg := Some c); (* I'm the (unique) winner, so I release the involved conjunction c, *) Conjunction.unlock egg_lock; (* and I unlock only the egg_lock (c remains locked) *) end else (Conjunction.unlock c') (* I loose the race, the resource must be immediately unlocked *) (* --- *) with Timeout -> () (* Ignore a timeout in a thread: exiting in this way the conjunction isn't locked *) end (* --- end of thread_behaviour --- *) in (* The father get the egg_lock before to spawn its children: *) Conjunction.lock egg_lock; (* Spawn all threads: *) let txcs : (Thread.t * (bool ref) * Conjunction.c) list = List.map (fun (c,c') -> let x = ref false in (* here x means terminated *) let t = Thread.create thread_behaviour (c,c',x) in (t,x,c)) cc's in (* Now wait for the egg. *) let success : bool = try begin let () = match timeout with | None -> while ((!egg) = None) do ignore (Conjunction.wait egg_lock); done | Some timeout -> let starting_time = Unix.gettimeofday () in while ((!egg) = None) do (if ((Unix.gettimeofday ()) -. starting_time) > timeout then raise Timeout); ignore (Conjunction.wait egg_lock) done in true (* Success, no timeout *) end with Timeout -> false in (* Here the egg is done and we have again the egg_lock. *) (* --- *) (* Now broadcast all living threads on the egg_lock, in order to force them to interrupt their waiting. No "false alarms" are generated directly here. *) let living = ref (List.filter (fun (t,x,c) -> not (!x)) txcs) in (* --- *) while (!living) <> [] do List.iter (fun (t,x,c) -> Conjunction.broadcast egg_lock) (!living); ignore (Conjunction.wait egg_lock); living := (List.filter (fun (t,x,c) -> not (!x)) (!living)); done; (* --- *) (* Here we have again the egg_lock. *) let involved_c = match (!egg) with Some c -> c | None -> assert false in let () = Conjunction.unlock egg_lock in (* --- *) if success then Some involved_c else raise Timeout end end include Disjunction let wait = Conjunction.wait let broadcast = Conjunction.broadcast let unlock = Conjunction.unlock let empty = zero type t = d (* a "lock" is a disjunction of conjunctions of basic locks *) (* Alias that helps to clarify the signature of try_lock: *) type 'a maybe = 'a option type alert = bool (* A "trailer" is an optional thunk executed out of the critical section, that is to say after unlocking the structure. *) type trailer = (unit -> unit) option (* val access : ?verbose:unit -> ?guard:(c->bool) -> t -> (c -> 'a * alert * trailer) -> 'a *) (** Execute thunk in a synchronized block, and return the value returned by the thunk. If executing thunk raises an exception, the same exception is propagated, after correctly unlocking. *) let access ?verbose ?guard ?timeout t (code) = (* The following call may raise the Timeout exception, that will be not catched here: *) match Disjunction.lock ?guard ?timeout t with | None -> raise Not_found (* empty disjunction: code cannot be applied *) | Some c -> (* success *) try (* The idea here is that the `code' recover its environment using the key `c': *) let result, alert, trailer = code (c) in let () = if alert then Conjunction.broadcast c else () in let () = Conjunction.unlock c in let () = match trailer with None -> () | Some thunk -> thunk () in result with e -> begin Conjunction.unlock c; if verbose = Some () then (Printf.eprintf "Lock.access: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)) else (); raise e; end (* Non-blocking version: *) let try_access ?verbose ?guard t (code : c -> 'a * alert * trailer) : 'a option = (* try_lock not lock: *) match Disjunction.try_lock ?guard t with | None -> None (* failure *) | Some None -> raise Not_found (* success, but empty disjunction: code cannot be applied *) | Some (Some c) -> (* success *) try (* The idea here is that the `code' recover its environment using the key `c': *) let result, alert, trailer = code (c) in let () = if alert then Conjunction.broadcast c else () in let () = Conjunction.unlock c in let () = match trailer with None -> () | Some thunk -> thunk () in Some result with e -> begin Conjunction.unlock c; if verbose = Some () then (Printf.eprintf "Lock.access: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)) else (); raise e; end ocamlbricks-0.90+bzr456.orig/CORTEX/locked.ml0000644000175000017500000004505513175721005017533 0ustar lucaslucas(* This file is part of ocamlbricks Copyright (C) 2017 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (* Do not remove the following comment: it's an ocamldoc workaround. *) (** *) module Set_as_array : sig type 'a t = 'a array type 'a compare = 'a -> 'a -> int (* --- *) val sum : ?compare:('a compare) -> 'a t list -> 'a t val product : ?compare:('a compare) -> 'a t list -> 'a list t val product_map : ?compare:('b compare) -> 'a t list -> ('a list -> 'b) -> 'b t (* --- *) val product1_map : ?compare:('b compare) -> 'a t -> ('a -> 'b) -> 'b t val product2_map : ?compare:('c compare) -> 'a t -> 'b t -> ('a -> 'b -> 'c) -> 'c t val product3_map : ?compare:('d compare) -> 'a t -> 'b t -> 'c t -> ('a -> 'b -> 'c -> 'd) -> 'd t val product4_map : ?compare:('e compare) -> 'a t -> 'b t -> 'c t -> 'd t -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'e t val product5_map : ?compare:('f compare) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'f t (* --- *) end = struct type 'a t = 'a array type 'a compare = 'a -> 'a -> int let sum ?(compare=compare) (ts : 'a t list) : 'a t = Array.of_list (List.sort_uniq compare (Array.to_list (Array.concat ts))) let p2 (xs:'a t) (ys:'b t) : ('a * 'b) t = let f = fun v l -> Array.map (fun x -> (v,x)) l in Array.concat (Array.to_list (Array.map (fun v -> f v ys) xs)) let p2_map (xs:'a t) (ys:'b t) g : 'c t = let f = fun v l -> Array.map (fun x -> g v x) l in Array.concat (Array.to_list (Array.map (fun v -> f v ys) xs)) let p3 (xs:'a t) (ys:'b t) (zs:'c t) : ('a * 'b * 'c) t = let f = fun v l -> Array.map (fun (x,y) -> (v,x,y)) l in Array.concat (Array.to_list (Array.map (fun v -> f v (p2 ys zs)) xs)) let p3_map (xs:'a t) (ys:'b t) (zs:'c t) g : 'd t = let f = fun v l -> Array.map (fun (x,y) -> g v x y) l in Array.concat (Array.to_list (Array.map (fun v -> f v (p2 ys zs)) xs)) let p4 (xs:'a t) (ys:'b t) (zs:'c t) (ts:'d t) : 'e t = let f = fun v l -> Array.map (fun (x,y,z) -> (v,x,y,z)) l in Array.concat (Array.to_list (Array.map (fun v -> f v (p3 ys zs ts)) xs)) let p4_map (xs:'a t) (ys:'b t) (zs:'c t) (ts:'d t) g : 'e t = let f = fun v l -> Array.map (fun (x,y,z) -> g v x y z) l in Array.concat (Array.to_list (Array.map (fun v -> f v (p3 ys zs ts)) xs)) let p5 (xs:'a t) (ys:'b t) (zs:'c t) (ts:'d t) (ws:'e t) : ('a * 'b * 'c * 'd * 'e) t = let f = fun v l -> Array.map (fun (x,y,z,t) -> (v,x,y,z,t)) l in Array.concat (Array.to_list (Array.map (fun v -> f v (p4 ys zs ts ws)) xs)) let p5_map (xs:'a t) (ys:'b t) (zs:'c t) (ts:'d t) (ws:'e t) g : 'f t = let f = fun v l -> Array.map (fun (x,y,z,t) -> g v x y z t) l in Array.concat (Array.to_list (Array.map (fun v -> f v (p4 ys zs ts ws)) xs)) (* --- *) let product1_map ?(compare=compare) xs g = Array.of_list (List.sort_uniq compare (Array.to_list (Array.map g xs))) let product2_map ?(compare=compare) xs ys g = Array.of_list (List.sort_uniq compare (Array.to_list (p2_map xs ys g))) let product3_map ?(compare=compare) xs ys zs g = Array.of_list (List.sort_uniq compare (Array.to_list (p3_map xs ys zs g))) let product4_map ?(compare=compare) xs ys zs ts g = Array.of_list (List.sort_uniq compare (Array.to_list (p4_map xs ys zs ts g))) let product5_map ?(compare=compare) xs ys zs ts ws g = Array.of_list (List.sort_uniq compare (Array.to_list (p5_map xs ys zs ts ws g))) (* --- *) let rec product (xss:'a t list) : ('a list) t = let f = fun v l -> Array.map (fun vs -> v::vs) l in match xss with | [] -> [|[]|] | xs::xss -> Array.concat (Array.to_list (Array.map (fun v -> f v (product xss)) xs)) let product_map ?(compare=compare) xss (f:'a list -> 'b) : 'b t = Array.of_list (List.sort_uniq (compare) (Array.to_list (Array.map f (product xss)))) (* Lexicographic extensions of `compare' for lists: *) let compare_list ~compare = let rec loop xs ys = match (xs,ys) with | [],[] -> 0 | [], _ -> (-1) | _ ,[] -> 1 | x::xs, y::ys -> let result = compare x y in if result = 0 then loop xs ys else result in loop (* Redefinition (sort_uniq): *) let product ?(compare=compare) xss = Array.of_list (List.sort_uniq (compare_list ~compare) (Array.to_list (product xss))) end (* Set_as_array *) module Disjunction : sig (* --- *) type 'a d = ('a c) array and 'a c = Lock.c * 'a and 'a locked = ('a c) option (* the actual locked value, if any (i.e. if the disjunction is not empty) *) (* --- *) val return : 'a -> 'a d (* make a structure protected by a basic lock (mutex) *) val fictive : 'a -> 'a d (* make a not really protected structure (i.e. protected by the empty set of conjunctions) *) (* --- *) val zero : 'a d (* identity element of the sum (the empty set of conjunctions) *) val sum : ('a d) list -> 'a d (* --- *) (* Simple products: *) val product : ('a d) list -> ('a list) d val product2 : ('a d) -> ('b d) -> ('a * 'b) d val product3 : ('a d) -> ('b d) -> ('c d) -> ('a * 'b * 'c) d val product4 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('a * 'b * 'c * 'd) d val product5 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('e d) -> ('a * 'b * 'c * 'd * 'e) d (* --- *) (* Compositional products: *) val cproduct : ('a d) list -> ('a list -> 'alist) -> ('alist) d val cproduct2 : ('a d) -> ('b d) -> ('a -> 'b -> 'ab) -> ('ab) d val cproduct3 : ('a d) -> ('b d) -> ('c d) -> ('a -> 'b -> 'c -> 'abc) -> ('abc) d val cproduct4 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('a -> 'b -> 'c -> 'd -> 'abcd) -> ('abcd) d val cproduct5 : ('a d) -> ('b d) -> ('c d) -> ('d d) -> ('e d) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'abcde) -> ('abcde) d (* --- *) val try_lock : ?guard:('a -> bool) -> 'a d -> ('a locked) option val lock : ?guard:('a -> bool) -> ?timeout:float -> 'a d -> 'a locked val wait : 'a locked -> Lock.b option (* the result is the basic lock where something has happen, if any *) val broadcast : 'a locked -> unit (* alert the involved conjunction *) val unlock : 'a locked -> unit end = struct type 'a d = ('a c) array and 'a c = Lock.Conjunction.c * 'a and 'a locked = ('a c) option (* the actual locked value, if any (i.e. if the disjunction is not empty) *) let return a = let c = Lock.Conjunction.create () in Array.make 1 (c,a) let fictive a = let c = Lock.Conjunction.unity in Array.make 1 (c,a) let zero = [||] let unity = [| (Lock.Conjunction.unity, ()) |] (* the "unity" is the singleton containing the empty conjunction of locks *) (* The same lock should not be associated to distinct memory adresses. But using fictive locks and composing them with real mutexes, we can obtain distinct structures locked by the same conjunction. Thus, the compare function is quite complex and acts on memory addresses. Furthermore, the behaviour of this function is not ideal, because it differentiate some structures that we should consider the same. For instance: let x, y = (ref 0), (ref 0) ;; (* distinct structures (currently) hosting the same value *) let v1, v2, v3 = ('A',x), ('A',x), ('A',y) ;; (* v1 and v2 will host forever the same content *) v1==v2, v1==v3, v2==v3 ;; (* (false, false, false) => not the equality I would *) v1=v2, v1=v3, v2=v3 ;; (* (true, true, true) => not the equality I would *) The structure v1 and v2 will host forever the same value because their persistent parts are identical and their mutable part are at the same address. So, ideally, the same lock may be used for v1 and v2. The compare function I would (may be written in OCaml?), should generate an equality such that: v1=v2, v1=v3, v2=v3 ;; (* (true, false, false) *) *) let compare = (* Hack from: https://rosettacode.org/wiki/Address_of_a_variable#OCaml*) let address_of (x:'a) : nativeint = if Obj.is_block (Obj.repr x) then Nativeint.shift_left (Nativeint.of_int (Obj.magic x)) 1 (* magic *) else raise Not_found in fun (c,a) (c',a') -> match (Lock.Conjunction.compare c c') with | 0 -> (* If locks are equals, the comparaison acts on memory adresses of the related data structure: *) Printf.kfprintf flush stderr "WARNING: lock comparison is 0\n"; if (a == a') then 0 else (* continue *) (* If fictive locks had been avoided, the code here should simply be (assert false) *) let () = Printf.kfprintf flush stderr "WARNING: lock comparison is 0 and addresses are different\n" in (try let m, m' = (address_of a), (address_of a') in Pervasives.compare m m' with (* Unboxed persistent value. We can apply Pervasives.compare: *) Not_found -> Printf.kfprintf flush stderr "WARNING: unboxed values\n"; Pervasives.compare a a') (* --- *) | result -> result (* n-ary sum. The meaning is: (c1 + c2) + c3 = (c1 + c2 + c3) *) let sum (ds : 'a d list) : 'a d = Set_as_array.sum ~compare ds (* n-ary product. The meaning is: (c1 + c2) ⋅ (c3 + c4 + c5) = (c1⋅c3 + c1⋅c4 + c1⋅c5 + c2⋅c3 + c2⋅c4 + c2⋅c5) *) let product (ds : 'a d list) : ('a list) d = if ds = [] then (assert false) else (* continue: *) let list_folding cxs = let cs,xs = List.split cxs in (Lock.Conjunction.product cs, xs) in Set_as_array.product_map ~compare ds (list_folding) (* n-ary compositional product. *) let cproduct (ds : 'a d list) (f:'a list -> 'alist) : ('alist) d = if ds = [] then (assert false) else (* continue: *) let list_folding cxs = let cs,xs = List.split cxs in (Lock.Conjunction.product cs, f xs) in Set_as_array.product_map ~compare ds (list_folding) let product2 (d1 : 'a d) (d2 : 'b d) : ('a * 'b) d = let fusion (c1,a) (c2,b) = (Lock.Conjunction.product [c1;c2], (a,b)) in Set_as_array.product2_map ~compare d1 d2 (fusion) let cproduct2 (d1 : 'a d) (d2 : 'b d) (f:'a -> 'b -> 'ab) : 'ab d = let fusion (c1,a) (c2,b) = (Lock.Conjunction.product [c1;c2], f a b) in Set_as_array.product2_map ~compare d1 d2 (fusion) let product3 (d1 : 'a d) (d2 : 'b d) (d3 : 'c d) : ('a * 'b * 'c) d = let fusion (c1,a) (c2,b) (c3,c) = (Lock.Conjunction.product [c1;c2;c3], (a,b,c)) in Set_as_array.product3_map ~compare d1 d2 d3 (fusion) let cproduct3 (d1 : 'a d) (d2 : 'b d) (d3 : 'c d) (f:'a -> 'b -> 'c -> 'abc) : ('abc) d = let fusion (c1,a) (c2,b) (c3,c) = (Lock.Conjunction.product [c1;c2;c3], f a b c) in Set_as_array.product3_map ~compare d1 d2 d3 (fusion) let product4 (d1 : 'a d) (d2 : 'b d) (d3 : 'c d) (d4 : 'd d) : ('a * 'b * 'c * 'd) d = let fusion (c1,a) (c2,b) (c3,c) (c4,d) = (Lock.Conjunction.product [c1;c2;c3;c4], (a,b,c,d)) in Set_as_array.product4_map ~compare d1 d2 d3 d4 (fusion) let cproduct4 (d1 : 'a d) (d2 : 'b d) (d3 : 'c d) (d4 : 'd d) (f:'a -> 'b -> 'c -> 'd -> 'abcd) : ('abcd) d = let fusion (c1,a) (c2,b) (c3,c) (c4,d) = (Lock.Conjunction.product [c1;c2;c3;c4], f a b c d) in Set_as_array.product4_map ~compare d1 d2 d3 d4 (fusion) let product5 (d1 : 'a d) (d2 : 'b d) (d3 : 'c d) (d4 : 'd d) (d5 : 'e d) : ('a * 'b * 'c * 'd * 'e) d = let fusion (c1,a) (c2,b) (c3,c) (c4,d) (c5,e) = (Lock.Conjunction.product [c1;c2;c3;c4;c5], (a,b,c,d,e)) in Set_as_array.product5_map ~compare d1 d2 d3 d4 d5 (fusion) let cproduct5 (d1 : 'a d) (d2 : 'b d) (d3 : 'c d) (d4 : 'd d) (d5 : 'e d) (f:'a -> 'b -> 'c -> 'd -> 'e -> 'abcde) : ('abcde) d = let fusion (c1,a) (c2,b) (c3,c) (c4,d) (c5,e) = (Lock.Conjunction.product [c1;c2;c3;c4;c5], f a b c d e) in Set_as_array.product5_map ~compare d1 d2 d3 d4 d5 (fusion) type 'a maybe = 'a option let hashtbl_of t = let size = (Array.length t) * 2 in let ht = Hashtbl.create (size) in let () = Array.iter (fun (c,a) -> Hashtbl.add ht c a) t in ht let adapt_guard ?guard (* 'a -> bool *) (ht) (involved:'a option ref) : (Lock.c -> bool) option = match guard with | None -> None | Some g -> (* --- *) let guard c = (* Note that this guard is always executed in mutual exclusion (see Lock.Disjunction.lock). Hence the access of the reference `involved' is protected: conflicting access are avoided. *) if (!involved) <> None then false else (* continue: *) try let xs = Hashtbl.find_all ht c in (* ht is shared but read-only *) (* The provided guard g is tested on all values associated to the same lock: *) let x = List.find (fun x -> try g x with _ -> false) xs in (* --- *) let () = (involved := Some (c,x)) in true (* <= This guard will not be never re-executed *) with Not_found -> false (* --- *) in Some guard let try_lock ?guard (t : 'a d) : 'a c option maybe = let ht = hashtbl_of t in let involved = ref None in (* involved structure *) let guard = adapt_guard ?guard (ht) (involved) in let cs = Array.map fst t in let d = Lock.of_conjunction_array cs in (* <= duplicated locks are removed here *) match Lock.try_lock ?guard d with | None -> None | Some (None) -> Some (None) | Some (Some c) -> (match !involved with | Some (c',x) -> let () = assert (c' == c) in Some (Some (c,x)) | None -> if guard = None then Some (Some (c, Hashtbl.find ht c)) else assert false) let lock ?guard ?timeout (t : 'a d) : 'a c option = let ht = hashtbl_of t in let involved = ref None in (* involved structure *) let guard = adapt_guard ?guard (ht) (involved) in let cs = Array.map fst t in let d = Lock.of_conjunction_array cs in (* <= duplicated locks are removed here *) match Lock.lock ?guard ?timeout d with | None -> None | Some c -> (match !involved with | Some (c',x) -> let () = assert (c' == c) in Some (c,x) | None -> if guard = None then Some (c, Hashtbl.find ht c) else assert false) (* val unlock : 'a locked -> unit *) let unlock = function | None -> () | Some (c,a) -> Lock.unlock c (* val wait : 'a locked -> Lock.b option (* the result is the basic lock where something has happen, if any *) *) let wait = function | None -> None | Some (c,a) -> Lock.wait c (* val broadcast : 'a locked -> unit (* alert the involved conjunction *) *) let broadcast = function | None -> () | Some (c,a) -> Lock.broadcast c end include Disjunction (* Should we alert other threads waiting on this structure? In other terms, should we perform a broadcast? *) type alert = bool (* A "trailer" is an optional thunk executed out of the critical section, that is to say after unlocking the structure. *) type trailer = (unit -> unit) option (** Execute thunk in a synchronized block, and return the value returned by the thunk. If executing thunk raises an exception, the same exception is propagated, after correctly unlocking. *) (* val access : ?verbose:unit -> ?guard:('a->bool) -> ?timeout:float -> 'a d -> ('a -> 'b * alert * trailer) -> 'b *) let access ?verbose ?guard ?timeout t (code) = (* The following call may raise the Timeout exception, that will be not catched here: *) let locked = Disjunction.lock ?guard ?timeout t in match locked with | None -> raise Not_found | Some (c,a) -> (try let result, alert, trailer = code a in let () = if alert then Lock.broadcast c else () in let () = Lock.unlock c in let () = match trailer with None -> () | Some thunk -> thunk () in result with e -> begin Lock.unlock c; if verbose = Some () then (Printf.eprintf "Locked.access: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)) else (); raise e; end) (* Simplified interface: *) let easy_access t (code) = let locked = Disjunction.lock t in match locked with | None -> raise Not_found | Some (c,a) -> (try let result = code a in let () = Lock.unlock c in result with e -> begin Lock.unlock c; raise e; end) (* val try_access : ?verbose:unit -> ?guard:('a->bool) -> 'a t -> ('a -> 'b * alert * trailer) -> 'b option *) let try_access ?verbose ?guard t (code) = let locked = Disjunction.try_lock ?guard t in match locked with | None -> None (* failure *) | Some None -> raise Not_found (* success, but empty disjunction: code cannot be applied *) | Some (Some (c,a)) -> (* success *) (try let result, alert, trailer = code a in let () = if alert then Lock.broadcast c else () in let () = Lock.unlock c in let () = match trailer with None -> () | Some thunk -> thunk () in Some result with e -> begin Lock.unlock c; if verbose = Some () then (Printf.eprintf "Locked.access: exception %s raised in critical section. Unlocking and re-raising.\n" (Printexc.to_string e)) else (); raise e; end) (* Simplified interface: *) let easy_try_access t (code) = let locked = Disjunction.try_lock t in match locked with | None -> None (* failure *) | Some None -> raise Not_found (* success, but empty disjunction: code cannot be applied *) | Some (Some (c,a)) -> (* success *) (try let result = code a in let () = Lock.unlock c in Some result with e -> begin Lock.unlock c; raise e; end) let empty = zero let make = return let unity = fictive type 'a t = 'a d (* val constructor : ('a -> 'b) -> 'a -> 'b d *) let constructor f = fun x -> return (f x) let involved_locks = function | None -> [||] | Some (c,a) -> c ocamlbricks-0.90+bzr456.orig/ocamlbricks.odocl0000644000175000017500000000247013175721005020241 0ustar lucaslucas# This file is part of our reusable OCaml BRICKS library # Copyright (C) 2008 Luca Saiu # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # This is simply a list of the OCaml modules (*not* filenames) for which # documentation should be generated: Argv ArrayExtra Configuration_files Container Cortex #Cortex2 Cortex_lib Counter Egg Either Endpoint Environments FilenameExtra Fix Forest Functor Future Hashmap Hashmmap Hashset Ipv4 Ipv6 Lazy_perishable Linux ListExtra #Lock #Locked Log_builder MapExtra Marshallable_classes Memo Mrproper MutexExtra Network Ocamlbricks_log Oomarshal Option PervasivesExtra QueueExtra Rev Semaphore Shell Spinning StrExtra StackExtra StringExtra String_queue Sugar SysExtra ThreadExtra Thunk UnixExtra Widget Wrapper ocamlbricks-0.90+bzr456.orig/tests/0000755000175000017500000000000013175721005016065 5ustar lucaslucasocamlbricks-0.90+bzr456.orig/tests/mutexExtra_test.ml0000644000175000017500000000647113175721005021634 0ustar lucaslucas(* This file is part of our reusable OCaml BRICKS library Copyright (C) 2011 Jean-Vincent Loddo Copyright (C) 2011 Université Paris 13 This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . *) (** Test program for recursive mutexes. *) (* Extended simple mutexes. *) module EMutex = MutexExtra.EMutex module Debug = struct let mutex = EMutex.create () let active = ref false let enable () = EMutex.with_mutex mutex (fun () -> active := true) let disable () = EMutex.with_mutex mutex (fun () -> active := false) let switch f x = if !active then (Lazy.force f) x else () let eprintf fmt = switch (lazy (EMutex.apply_with_mutex mutex (Printf.kfprintf flush stderr))) fmt let eprintf1 fmt x = switch (lazy (EMutex.apply_with_mutex mutex (Printf.kfprintf flush stderr fmt))) x let eprintf2 fmt x y = switch (lazy (EMutex.apply_with_mutex mutex (Printf.kfprintf flush stderr fmt x))) y let eprintf3 fmt x y z = switch (lazy (EMutex.apply_with_mutex mutex (Printf.kfprintf flush stderr fmt x y))) z end (* module Debug *) module Test (R: sig type t val create : unit -> t val lock : t -> unit val unlock : t -> unit val with_mutex : ?verbose:unit -> t -> (unit -> 'a) -> 'a val apply_with_mutex : ?verbose:unit -> t -> ('a -> 'b) -> 'a -> 'b end) = struct let () = Random.self_init () let counter = ref 0 let mutex = R.create () let rec loop ~action = function | 0 -> () | 1 -> R.with_mutex mutex action | n -> R.apply_with_mutex mutex (loop ~action) (n-1) let thread_life ~max_iterations_per_thread ~max_depth () = let iterations = Random.int (max_iterations_per_thread+1) in let depth = Random.int (max_depth+1) in for i = 1 to iterations do loop ~action:(fun () -> incr counter) depth; (* Here may be interrupted *) Thread.delay 0.01; loop ~action:(fun () -> decr counter) depth; done let go ?(thread_no=1500) ?(max_iterations_per_thread=200) ?(max_depth=5) () = Debug.enable (); Debug.eprintf "Testing with:\n"; Debug.eprintf1 " thread_no=%d\n" thread_no; Debug.eprintf1 " max_iterations_per_thread=%d\n" max_iterations_per_thread ; Debug.eprintf1 " max_depth=%d (maximal recursive lock number)\n" max_depth ; Debug.eprintf1 "BEGIN: counter=%d\n" !counter; let ts = Array.init thread_no (fun i -> let t = Thread.create (thread_life ~max_iterations_per_thread ~max_depth) () in Debug.eprintf1 "i=%d\r" (i+1); Thread.delay 0.005; t ) in Array.iter Thread.join ts; Debug.eprintf1 "\rEND: counter=%d\n" !counter; if !counter = 0 then Debug.eprintf "Test ok.\n" else Debug.eprintf "Test KO: unexpected result: at this point counter would be 0\n" ; flush stderr end;; (* module Test *) let module T = Test (MutexExtra.Recursive) in T.go () ocamlbricks-0.90+bzr456.orig/AUTHORS0000644000175000017500000000176213175721005016001 0ustar lucaslucasThis file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2008 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Authors ======= This project is by: Jean-Vincent Loddo ------------------ E-mail: loddo@lipn.univ-paris13.fr Home page: http://www-lipn.univ-paris13.fr/~loddo Luca Saiu --------- E-mail: saiu@lipn.univ-paris13.fr Home page: http://www-lipn.univ-paris13.fr/~saiu ocamlbricks-0.90+bzr456.orig/THANKS0000644000175000017500000000146413175721005015643 0ustar lucaslucasThis file is part of our reusable OCaml BRICKS library Copyright (C) 2008 Luca Saiu Copyright (C) 2008 Jean-Vincent Loddo This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . The authors wish to thank: - ... [To do: write this.] - ... [To do: write this.]