Commits

Paweł Wieczorek committed 2cd28f1

Utilities

Comments (0)

Files changed (30)

 let define_internal_libraries () =
     ocaml_lib
         ~tag_name:"use_util"
-        "source/Util";
-    ocaml_lib
-        ~tag_name:"use_lib"
-        "source/Lib";
+        "source/Utilities";
     ocaml_lib
         ~tag_name:"use_command"
         "source/Command";
     ocaml_lib
-        ~tag_name:"use_lang"
-        "source/Lang";
-    ocaml_lib
         ~tag_name:"use_compiler"
         "source/Compiler";
     ocaml_lib

source/Util.mllib

-DataModuleTypes
-Error
-Raise
-Graph
-Log
-RestrictedHashtbl
-Tty
-Util
-Tempfile
-FrozenHashtbl
-ManagedRef

source/Util/DataModuleTypes.ml

-open Batteries
-
-module type EqType = sig
-
-    type t
-
-    val equal : t -> t -> bool
-
-end
-
-
-module EqTypeFromOrderedType (M : Interfaces.OrderedType) = struct
-
-    type t = M.t
-
-    let equal a b = M.compare a b == 0
-
-end
-
-module EqTypeFromBuiltIn ( M : sig type t end ) = struct
-
-    type t = M.t
-
-    let equal a b = a = b
-
-end

source/Util/Error.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-(*********************************************************************************************************************
- * Common exceptions
- ********************************************************************************************************************)
-
-exception Not_yet_implemented of string
-
-exception Internal_error of string
-
-exception Command_failed of string
-
-exception Failed of string list
-
-
-(*********************************************************************************************************************
- * Helpers
- ********************************************************************************************************************)
-
-let not_yet_implemented msg =
-    Raise.raise_exception_with_debug_info (Not_yet_implemented msg)
-
-let internal_error msg =
-    Raise.raise_exception_with_debug_info (Internal_error msg)
-
-let command_failed msg =
-    Raise.raise_exception_with_debug_info (Command_failed msg)
-
-let failed msgs =
-    Raise.raise_exception_with_debug_info  (Failed msgs)
-
-
-(*********************************************************************************************************************
- * Printer
- ********************************************************************************************************************)
-
-module ExceptionPrinter = struct
-
-    let unpack_exception = function
-        | Not_yet_implemented msg -> ("Error.Not_yet_implemented", msg)
-        | Internal_error msg -> ("Error.Internal_error", msg)
-        | Command_failed msg -> ("Error.Command_failed", msg)
-        | Failed msgs -> ("Error.Failed", String.concat " " msgs)
-        | _ ->
-            raise Exit
-
-    let exception_printer exn =
-        try
-            let (name, msg) = unpack_exception exn in
-            Some (Printf.sprintf "%s(%S)" name msg)
-        with Exit ->
-            None
-
-    let _ =
-        Printexc.register_printer exception_printer
-
-end

source/Util/FrozenHashtbl.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-
-(*********************************************************************************************************************
- *
- ********************************************************************************************************************)
-
-type ('k, 'v) t = ('k, 'v) Hashtbl.t
-
-let freeze t = (Hashtbl.copy t)
-
-let find h k = Hashtbl.find h k
-
-let fold f h a = Hashtbl.fold f h a

source/Util/FrozenHashtbl.mli

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-
-(*********************************************************************************************************************
- *
- ********************************************************************************************************************)
-
-type ('k, 'v) t
-
-val freeze : ('k, 'v) Hashtbl.t -> ('k, 'v) t
-
-val find : ('k, 'v) t -> 'k -> 'v
-
-val fold : ('k -> 'v -> 'a -> 'a) -> ('k, 'v) t -> 'a -> 'a
-

source/Util/Graph.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-
-type 'a digraph = ('a, 'a list) Hashtbl.t
-
-
-let __add htbl k x = 
-    try 
-        let xs = Hashtbl.find htbl k in
-        Hashtbl.replace htbl k (x::xs)
-    with _ ->
-        Hashtbl.replace htbl k [x]
-
-let __remove htbl k x =
-    try
-        let xs = Hashtbl.find htbl k in
-        Hashtbl.replace htbl k (List.filter ( (=) x ) xs)
-    with _ ->
-        ()
-
-let create () = (Hashtbl.create 1027, Hashtbl.create 1027)
-
-let add_edge (graph,revgraph) parent child = 
-    __add graph    parent child;
-    __add revgraph child parent
-
-let remove_edge (graph, revgraph) parent child =
-    __remove graph parent child;
-    __remove revgraph child parent
-
-let get_children (graph, revgraph) parent =
-    try
-        Hashtbl.find graph parent
-    with _ ->
-        []
-
-let get_parents (graph, revgraph) child =
-    try
-        Hashtbl.find revgraph child
-    with _ ->
-        []
-
-let iter (graph, revgraph) f =
-    Hashtbl.iter (fun k xs -> f k; List.iter f xs) graph
-
-let weak_reverse (graph, revgraph) = (revgraph, graph)
-
-let reverse (graph, revgraph) = (Hashtbl.copy revgraph, Hashtbl.copy graph)

source/Util/Log.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-
-(*********************************************************************************************************************
- * Types
- ********************************************************************************************************************)
-
-type level
-    = DEBUG
-    | INFO
-    | WARNING
-    | ERROR
-
-(*********************************************************************************************************************
- * Log-device
- ********************************************************************************************************************)
-
-let current_log_level  = ref DEBUG
-
-let string_of_level = function
-    | DEBUG     -> "DEBUG"
-    | INFO      -> "INFO"
-    | WARNING   -> "WARNING"
-    | ERROR     -> "ERROR"
-
-let ansi_esc_of_level = function
-    | DEBUG     -> "\x1b[30;45m"
-    | INFO      -> "\x1b[30;47m"
-    | WARNING   -> "\x1b[30;43m"
-    | ERROR     -> "\x1b[30;41m"
-
-(*********************************************************************************************************************
- *
- ********************************************************************************************************************)
-
-let log_output level message =
-    if !current_log_level <= level then
-    Printf.eprintf "%s[%7s]%s %s\n%!"
-        (ansi_esc_of_level level)
-        (string_of_level level)
-        "\x1b[0m"
-        message
-
-let logstring_of_painter painter =
-    StringPainter.Prioritized.render_painter Pervasives.stdout painter
-
-let logstring_of_painters painters =
-    logstring_of_painter (StringPainter.Prioritized.psp_group painters)
-
-let painter = StringPainter.Prioritized.print_painter
-
-(*********************************************************************************************************************
- *
- ********************************************************************************************************************)
-
-let error fmt = 
-    Printf.ksprintf (log_output ERROR) fmt
-
-let warning fmt = 
-    Printf.ksprintf (log_output WARNING) fmt
-
-let info fmt = 
-    Printf.ksprintf (log_output INFO) fmt
-
-let debug fmt = 
-    Printf.ksprintf (log_output DEBUG) fmt
-

source/Util/ManagedRef.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-
-(*********************************************************************************************************************
- *
- ********************************************************************************************************************)
-
-type 'a t = 'a option ref
-
-let create () = ref None
-
-let is_empty = function
-    | { contents = None } ->
-        true
-
-    | _ ->
-        false
-
-let is_initialized mr = not (is_empty mr)
-
-let release = function
-    | { contents = Some r } as mr ->
-        mr := None;
-        r
-
-    | _  ->
-        Error.internal_error
-            "releasing empty managed reference"
-
-let alter f = function
-    | { contents = Some r } as mr ->
-        mr := Some (f r)
-
-    | _  ->
-        Error.internal_error
-            "altering empty managed reference"
-
-let try_alter f = function
-    | { contents = Some r } as mr ->
-        mr := Some (f r)
-
-    | _ ->
-        ()
-
-let clone mr = ref !mr
-
-let replace mr x = mr := Some x
-
-let update f  = function
-    | { contents = Some r } ->
-        f r
-
-    | _ ->
-        Error.internal_error
-            "updating empty managed reference"
-
-module Autoinit = struct
-
-    let autoinitialize creator mr =
-        if is_empty mr then
-            replace mr (creator ())
-
-    let update creator f mr =
-        autoinitialize creator mr;
-        update f mr
-
-    let alter creator f mr =
-        autoinitialize creator mr;
-        alter f mr
-
-    let release creator mr =
-        autoinitialize creator mr;
-        release mr
-
-end

source/Util/ManagedRef.mli

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-
-(*********************************************************************************************************************
- * Type
- ********************************************************************************************************************)
-
-type 'a t
-
-
-val create : unit -> 'a t
-
-val is_empty : 'a t -> bool
-
-val is_initialized : 'a t -> bool
-
-val release : 'a t -> 'a
-
-val alter : ('a -> 'a) -> 'a t -> unit
-
-val try_alter : ('a -> 'a) -> 'a t -> unit
-
-val clone : 'a t -> 'a t
-
-val replace : 'a t -> 'a -> unit
-
-val update : ('a -> unit) -> 'a t -> unit
-
-module Autoinit : sig
-
-    val update : (unit -> 'a) -> ('a -> unit) -> 'a t -> unit
-
-    val alter : (unit -> 'a) -> ('a -> 'a) -> 'a t -> unit
-
-    val release : (unit -> 'a) -> 'a t -> 'a 
-end

source/Util/Raise.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-
-let raise_exception exn =
-    raise exn
-
-
-let raise_exception_with_debug_info exn =
-    Log.debug "raised exception: %s" (Printexc.to_string exn);
-    raise_exception exn

source/Util/RestrictedHashtbl.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-(*********************************************************************************************************************
- * UTIL
- ********************************************************************************************************************)
-
-open Batteries
-open ManagedRef
-
-type ('k, 'v) t = ('k, 'v) Hashtbl.t
-
-exception Already_added
-
-let create n = Hashtbl.create n
-
-let find ht k =
-    Hashtbl.find ht k
-
-let insert ht k v = 
-    try
-        ignore (find ht k);
-        raise Already_added
-    with
-        | Not_found ->
-            Hashtbl.replace ht k v
-
-let hashtbl_of_restricted_hashtbl ht = ht
-
-let iter ht f = Hashtbl.iter (hashtbl_of_restricted_hashtbl ht) f
-
-let fold a b c = Hashtbl.fold a b  (hashtbl_of_restricted_hashtbl c) 
-
-let map f hashtable = 
-    let handle_def k v = 
-        Hashtbl.replace hashtable k (f k v)
-        in
-
-    iter handle_def hashtable
-

source/Util/Tempfile.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-
-(*********************************************************************************************************************
- *
- ********************************************************************************************************************)
-
-let with_temp_filename source_filename_opt suffix cont = match source_filename_opt with
-    | Some source_filename ->
-        let tmp_filename    = Util.get_filename_base source_filename ^ suffix in
-        cont tmp_filename 
-
-    | None ->
-        let tmp_filename = Filename.temp_file "opifex" suffix in
-        let r = cont tmp_filename in
-        Sys.remove tmp_filename;
-        r
-
-let with_temp_file source_filename_opt suffix cont = match source_filename_opt with
-    | Some source_filename ->
-        let tmp_filename    = Util.get_filename_base source_filename ^ suffix in
-        let tmp_channel_out = open_out tmp_filename in
-        let r = cont tmp_filename tmp_channel_out in
-        close_out_noerr tmp_channel_out;
-        r
-
-    | None ->
-        let tmp_filename, tmp_channel_out = Filename.open_temp_file "opifex" suffix in
-        let r = cont tmp_filename tmp_channel_out in
-        close_out_noerr tmp_channel_out;
-        Sys.remove tmp_filename;
-        r
-
-let with_painted_temp_file source_filename_opt suffix painter cont = 
-    with_temp_file source_filename_opt suffix begin fun tmp_filename tmp_channel_out ->
-        StringPainter.Prioritized.print_painter_nl tmp_channel_out painter;
-        cont tmp_filename
-    end
-
-let with_painting_to_temp_file source_filename_opt suffix f x cont =
-    with_painted_temp_file source_filename_opt suffix (f x) cont

source/Util/Tty.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-type color_string = string
-
-type output_driver =
-    { _emph     : string -> color_string
-    ; _yellow   : string -> color_string
-    ; _blue     : string -> color_string
-    ; _red      : string -> color_string
-    ; _green    : string -> color_string
-    ; _cyan     : string -> color_string
-    ; _black    : string -> color_string
-    ; _magenta  : string -> color_string
-    ; _grey     : string -> color_string
-    }
-
-let raw_output_driver =
-    { _emph     = (fun x -> x)
-    ; _yellow   = (fun x -> x)
-    ; _blue     = (fun x -> x)
-    ; _red      = (fun x -> x)
-    ; _green    = (fun x -> x)
-    ; _cyan     = (fun x -> x)
-    ; _black    = (fun x -> x)
-    ; _magenta  = (fun x -> x)
-    ; _grey     = (fun x -> x)
-    }
-
-let tty_output_driver =
-    let lr open_esc str = Util.concat_strings [ open_esc ; str ; "\027[0m" ] in
-    { _emph      = lr "\027[1m" 
-    ; _black     = lr "\027[30m"
-    ; _red       = lr "\027[31m"
-    ; _green     = lr "\027[32m"
-    ; _yellow    = lr "\027[33m"
-    ; _blue      = lr "\027[34m"
-    ; _magenta   = lr "\027[35m"
-    ; _cyan      = lr "\027[36m"
-    ; _grey      = lr "\027[37m"
-    }
-
-let determine_output_driver out_channel = 
-    try
-        ignore (Unix.getenv "OPIFEX_NOCOLORS");
-        raw_output_driver
-    with
-        | Not_found -> 
-            if Unix.isatty (Unix.descr_of_out_channel out_channel)
-                then
-                    tty_output_driver
-                else
-                    raw_output_driver
-
-
-let output_driver = ref (determine_output_driver stdout)
-
-let emph    s = (!output_driver)._emph s
-let yellow  s = (!output_driver)._yellow s
-let blue    s = (!output_driver)._blue s
-let red     s = (!output_driver)._red s
-let green   s = (!output_driver)._green s
-let cyan    s = (!output_driver)._cyan s
-let black   s = (!output_driver)._black s
-let magenta s = (!output_driver)._magenta s
-let grey    s = (!output_driver)._grey s
-
-

source/Util/Util.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-(*********************************************************************************************************************
- * UTIL
- ********************************************************************************************************************)
-
-open Batteries
-
-let concat_strings = List.fold_left (^) ""
-
-let concat_intersperse' ch = function
-    | [] ->
-        []
-
-    | (s::ss) ->
-        List.fold_left (fun a b -> a @ ch @ b) s ss
-
-let concat_intersperse ch = function
-    | [] ->
-        ""
-
-    | (s::ss) ->
-        List.fold_left (fun a b -> a ^ ch ^ b) s ss
-
-let concat_words = concat_intersperse " "
-
-let concat_lines = concat_intersperse "\n"
-
-let compose f g x = f (g x)
-
-let _print_strings f = concat_strings %> f
-let _print_words   f = concat_words %> f
-
-let print_strings_ln = _print_strings print_endline
-let print_strings    = _print_strings print_string
-
-let print_words_ln   = _print_words print_endline
-let print_words      = _print_words print_string
-
-let print_lines      = concat_lines %> print_endline
-
-let rec concat_map f = List.map f %> List.concat
-
-let list_of_hashtbl hashtbl = 
-    Hashtbl.fold (fun k v aux -> (k,v)::aux) hashtbl []
-
-let increment_ref_ r =
-    r := succ !r
-
-let increment_ref r =
-    let value = !r in
-    increment_ref_ r;
-    value
-
-let uncurry f (a,b) = f a b
-
-let curry f a b = f (a,b)
-
-let when0 pred f x =
-    if pred then f x else x
-
-let until0 pred = when0 (not pred)
-
-let when1 pred f x = when0 (pred x)
-
-let until1 pred    = when1 (not %> pred)
-
-let apply f x = f x
-
-let revapply x f = f x
-
-let applies_from_left fs x = List.fold_left revapply x fs
-
-let applies_from_right fs x = List.fold_right apply fs x
-
-let rec iter_until_ok f = function
-    | [] ->
-        0
-    | x::xs ->
-        let r = f x in
-        if r = 0 then
-            iter_until_ok f xs
-        else
-            r
-
-let marshal hint f x =
-    let fname = "marshal." ^ hint ^ ".dump" in
-    let h     = open_out fname in
-    let res   = f x in
-    Marshal.to_channel h res [];
-    res
-
-let unmarshal hint =
-    let fname = "marshal." ^ hint ^ ".dump" in
-    let h     = open_in fname in
-    Marshal.from_channel h
-
-
-type ('a,'b) either
-    = Left of 'a
-    | Right of 'b
-
-
-let container_from_list add empty xs =
-    List.fold_right add xs empty 
-
-module ExtSet (M : Set.S) = struct
-    include M
-
-    let from_list = container_from_list M.add M.empty
-
-    let diff_list s xs = List.fold_left (fun set x -> remove x set) s xs
-
-    let to_list set = fold (fun elt aux -> elt::aux) set []
-end
-
-module ExtMap (M : Map.S) = struct
-    include M
-
-    let diff m1 m2 = 
-        let f k v m =
-            M.remove k m
-            in
-        M.fold f m2 m1
-
-    let diff_list m1 xs =
-        let f k m =
-            M.remove k m
-            in
-        List.fold_right f xs m1
-
-end
-
-let call_command cmd parameters =
-    let command = String.concat " " (cmd :: parameters) in
-    Log.debug "Calling command: %s" command;
-    let exit_code = Sys.command command  in
-    if exit_code <> 0 then begin
-        Log.debug "Command %S returned with exit code %i" command exit_code;
-        Error.command_failed command
-        end
-
-
-let get_filename_base filename = 
-    try 
-        let idx = String.rindex (Filename.basename filename) '.' in
-        String.sub (Filename.basename filename) 0 idx
-    with Not_found ->
-        Filename.basename filename
-
-let get_filename_with_suffix suffix filename =
-    get_filename_base filename ^ suffix
-
-
-let cartesian_product_2 = List.cartesian_product
-
-let cartesian_product_3 xs1 xs2 xs3 =
-    let cart = cartesian_product_2 xs1 xs2 in
-    let fix (a,b) c = (a,b,c) in
-    concat_map (fun p -> List.map (fix p) xs3) cart
-
-let cartesian_product_4 xs1 xs2 xs3 xs4 =
-    let cart = cartesian_product_3 xs1 xs2 xs3 in
-    let fix (a,b,c) d = (a,b,c,d) in
-    concat_map (fun p -> List.map (fix p) xs4) cart

source/Utilities.mllib

+DataModuleTypes
+Error
+Raise
+Graph
+Log
+RestrictedHashtbl
+Tty
+Util
+Tempfile
+FrozenHashtbl
+ManagedRef

source/Utilities/DataModuleTypes.ml

+open Batteries
+
+module type EqType = sig
+
+    type t
+
+    val equal : t -> t -> bool
+
+end
+
+
+module EqTypeFromOrderedType (M : Interfaces.OrderedType) = struct
+
+    type t = M.t
+
+    let equal a b = M.compare a b == 0
+
+end
+
+module EqTypeFromBuiltIn ( M : sig type t end ) = struct
+
+    type t = M.t
+
+    let equal a b = a = b
+
+end

source/Utilities/Error.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+(*********************************************************************************************************************
+ * Common exceptions
+ ********************************************************************************************************************)
+
+exception Not_yet_implemented of string
+
+exception Internal_error of string
+
+exception Command_failed of string
+
+exception Failed of string list
+
+
+(*********************************************************************************************************************
+ * Helpers
+ ********************************************************************************************************************)
+
+let not_yet_implemented msg =
+    Raise.raise_exception_with_debug_info (Not_yet_implemented msg)
+
+let internal_error msg =
+    Raise.raise_exception_with_debug_info (Internal_error msg)
+
+let command_failed msg =
+    Raise.raise_exception_with_debug_info (Command_failed msg)
+
+let failed msgs =
+    Raise.raise_exception_with_debug_info  (Failed msgs)
+
+
+(*********************************************************************************************************************
+ * Printer
+ ********************************************************************************************************************)
+
+module ExceptionPrinter = struct
+
+    let unpack_exception = function
+        | Not_yet_implemented msg -> ("Error.Not_yet_implemented", msg)
+        | Internal_error msg -> ("Error.Internal_error", msg)
+        | Command_failed msg -> ("Error.Command_failed", msg)
+        | Failed msgs -> ("Error.Failed", String.concat " " msgs)
+        | _ ->
+            raise Exit
+
+    let exception_printer exn =
+        try
+            let (name, msg) = unpack_exception exn in
+            Some (Printf.sprintf "%s(%S)" name msg)
+        with Exit ->
+            None
+
+    let _ =
+        Printexc.register_printer exception_printer
+
+end

source/Utilities/FrozenHashtbl.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+type ('k, 'v) t = ('k, 'v) Hashtbl.t
+
+let freeze t = (Hashtbl.copy t)
+
+let find h k = Hashtbl.find h k
+
+let fold f h a = Hashtbl.fold f h a

source/Utilities/FrozenHashtbl.mli

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+type ('k, 'v) t
+
+val freeze : ('k, 'v) Hashtbl.t -> ('k, 'v) t
+
+val find : ('k, 'v) t -> 'k -> 'v
+
+val fold : ('k -> 'v -> 'a -> 'a) -> ('k, 'v) t -> 'a -> 'a
+

source/Utilities/Graph.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+type 'a digraph = ('a, 'a list) Hashtbl.t
+
+
+let __add htbl k x = 
+    try 
+        let xs = Hashtbl.find htbl k in
+        Hashtbl.replace htbl k (x::xs)
+    with _ ->
+        Hashtbl.replace htbl k [x]
+
+let __remove htbl k x =
+    try
+        let xs = Hashtbl.find htbl k in
+        Hashtbl.replace htbl k (List.filter ( (=) x ) xs)
+    with _ ->
+        ()
+
+let create () = (Hashtbl.create 1027, Hashtbl.create 1027)
+
+let add_edge (graph,revgraph) parent child = 
+    __add graph    parent child;
+    __add revgraph child parent
+
+let remove_edge (graph, revgraph) parent child =
+    __remove graph parent child;
+    __remove revgraph child parent
+
+let get_children (graph, revgraph) parent =
+    try
+        Hashtbl.find graph parent
+    with _ ->
+        []
+
+let get_parents (graph, revgraph) child =
+    try
+        Hashtbl.find revgraph child
+    with _ ->
+        []
+
+let iter (graph, revgraph) f =
+    Hashtbl.iter (fun k xs -> f k; List.iter f xs) graph
+
+let weak_reverse (graph, revgraph) = (revgraph, graph)
+
+let reverse (graph, revgraph) = (Hashtbl.copy revgraph, Hashtbl.copy graph)

source/Utilities/Log.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+
+(*********************************************************************************************************************
+ * Types
+ ********************************************************************************************************************)
+
+type level
+    = DEBUG
+    | INFO
+    | WARNING
+    | ERROR
+
+(*********************************************************************************************************************
+ * Log-device
+ ********************************************************************************************************************)
+
+let current_log_level  = ref DEBUG
+
+let string_of_level = function
+    | DEBUG     -> "DEBUG"
+    | INFO      -> "INFO"
+    | WARNING   -> "WARNING"
+    | ERROR     -> "ERROR"
+
+let ansi_esc_of_level = function
+    | DEBUG     -> "\x1b[30;45m"
+    | INFO      -> "\x1b[30;47m"
+    | WARNING   -> "\x1b[30;43m"
+    | ERROR     -> "\x1b[30;41m"
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+let log_output level message =
+    if !current_log_level <= level then
+    Printf.eprintf "%s[%7s]%s %s\n%!"
+        (ansi_esc_of_level level)
+        (string_of_level level)
+        "\x1b[0m"
+        message
+
+let logstring_of_painter painter =
+    StringPainter.Prioritized.render_painter Pervasives.stdout painter
+
+let logstring_of_painters painters =
+    logstring_of_painter (StringPainter.Prioritized.psp_group painters)
+
+let painter = StringPainter.Prioritized.print_painter
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+let error fmt = 
+    Printf.ksprintf (log_output ERROR) fmt
+
+let warning fmt = 
+    Printf.ksprintf (log_output WARNING) fmt
+
+let info fmt = 
+    Printf.ksprintf (log_output INFO) fmt
+
+let debug fmt = 
+    Printf.ksprintf (log_output DEBUG) fmt
+

source/Utilities/ManagedRef.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+type 'a t = 'a option ref
+
+let create () = ref None
+
+let is_empty = function
+    | { contents = None } ->
+        true
+
+    | _ ->
+        false
+
+let is_initialized mr = not (is_empty mr)
+
+let release = function
+    | { contents = Some r } as mr ->
+        mr := None;
+        r
+
+    | _  ->
+        Error.internal_error
+            "releasing empty managed reference"
+
+let alter f = function
+    | { contents = Some r } as mr ->
+        mr := Some (f r)
+
+    | _  ->
+        Error.internal_error
+            "altering empty managed reference"
+
+let try_alter f = function
+    | { contents = Some r } as mr ->
+        mr := Some (f r)
+
+    | _ ->
+        ()
+
+let clone mr = ref !mr
+
+let replace mr x = mr := Some x
+
+let update f  = function
+    | { contents = Some r } ->
+        f r
+
+    | _ ->
+        Error.internal_error
+            "updating empty managed reference"
+
+module Autoinit = struct
+
+    let autoinitialize creator mr =
+        if is_empty mr then
+            replace mr (creator ())
+
+    let update creator f mr =
+        autoinitialize creator mr;
+        update f mr
+
+    let alter creator f mr =
+        autoinitialize creator mr;
+        alter f mr
+
+    let release creator mr =
+        autoinitialize creator mr;
+        release mr
+
+end

source/Utilities/ManagedRef.mli

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+(*********************************************************************************************************************
+ * Type
+ ********************************************************************************************************************)
+
+type 'a t
+
+
+val create : unit -> 'a t
+
+val is_empty : 'a t -> bool
+
+val is_initialized : 'a t -> bool
+
+val release : 'a t -> 'a
+
+val alter : ('a -> 'a) -> 'a t -> unit
+
+val try_alter : ('a -> 'a) -> 'a t -> unit
+
+val clone : 'a t -> 'a t
+
+val replace : 'a t -> 'a -> unit
+
+val update : ('a -> unit) -> 'a t -> unit
+
+module Autoinit : sig
+
+    val update : (unit -> 'a) -> ('a -> unit) -> 'a t -> unit
+
+    val alter : (unit -> 'a) -> ('a -> 'a) -> 'a t -> unit
+
+    val release : (unit -> 'a) -> 'a t -> 'a 
+end

source/Utilities/Raise.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+let raise_exception exn =
+    raise exn
+
+
+let raise_exception_with_debug_info exn =
+    Log.debug "raised exception: %s" (Printexc.to_string exn);
+    raise_exception exn

source/Utilities/RestrictedHashtbl.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+(*********************************************************************************************************************
+ * UTIL
+ ********************************************************************************************************************)
+
+open Batteries
+open ManagedRef
+
+type ('k, 'v) t = ('k, 'v) Hashtbl.t
+
+exception Already_added
+
+let create n = Hashtbl.create n
+
+let find ht k =
+    Hashtbl.find ht k
+
+let insert ht k v = 
+    try
+        ignore (find ht k);
+        raise Already_added
+    with
+        | Not_found ->
+            Hashtbl.replace ht k v
+
+let hashtbl_of_restricted_hashtbl ht = ht
+
+let iter ht f = Hashtbl.iter (hashtbl_of_restricted_hashtbl ht) f
+
+let fold a b c = Hashtbl.fold a b  (hashtbl_of_restricted_hashtbl c) 
+
+let map f hashtable = 
+    let handle_def k v = 
+        Hashtbl.replace hashtable k (f k v)
+        in
+
+    iter handle_def hashtable
+

source/Utilities/Tempfile.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+
+(*********************************************************************************************************************
+ *
+ ********************************************************************************************************************)
+
+let with_temp_filename source_filename_opt suffix cont = match source_filename_opt with
+    | Some source_filename ->
+        let tmp_filename    = Util.get_filename_base source_filename ^ suffix in
+        cont tmp_filename 
+
+    | None ->
+        let tmp_filename = Filename.temp_file "opifex" suffix in
+        let r = cont tmp_filename in
+        Sys.remove tmp_filename;
+        r
+
+let with_temp_file source_filename_opt suffix cont = match source_filename_opt with
+    | Some source_filename ->
+        let tmp_filename    = Util.get_filename_base source_filename ^ suffix in
+        let tmp_channel_out = open_out tmp_filename in
+        let r = cont tmp_filename tmp_channel_out in
+        close_out_noerr tmp_channel_out;
+        r
+
+    | None ->
+        let tmp_filename, tmp_channel_out = Filename.open_temp_file "opifex" suffix in
+        let r = cont tmp_filename tmp_channel_out in
+        close_out_noerr tmp_channel_out;
+        Sys.remove tmp_filename;
+        r
+
+let with_painted_temp_file source_filename_opt suffix painter cont = 
+    with_temp_file source_filename_opt suffix begin fun tmp_filename tmp_channel_out ->
+        StringPainter.Prioritized.print_painter_nl tmp_channel_out painter;
+        cont tmp_filename
+    end
+
+let with_painting_to_temp_file source_filename_opt suffix f x cont =
+    with_painted_temp_file source_filename_opt suffix (f x) cont

source/Utilities/Tty.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+type color_string = string
+
+type output_driver =
+    { _emph     : string -> color_string
+    ; _yellow   : string -> color_string
+    ; _blue     : string -> color_string
+    ; _red      : string -> color_string
+    ; _green    : string -> color_string
+    ; _cyan     : string -> color_string
+    ; _black    : string -> color_string
+    ; _magenta  : string -> color_string
+    ; _grey     : string -> color_string
+    }
+
+let raw_output_driver =
+    { _emph     = (fun x -> x)
+    ; _yellow   = (fun x -> x)
+    ; _blue     = (fun x -> x)
+    ; _red      = (fun x -> x)
+    ; _green    = (fun x -> x)
+    ; _cyan     = (fun x -> x)
+    ; _black    = (fun x -> x)
+    ; _magenta  = (fun x -> x)
+    ; _grey     = (fun x -> x)
+    }
+
+let tty_output_driver =
+    let lr open_esc str = Util.concat_strings [ open_esc ; str ; "\027[0m" ] in
+    { _emph      = lr "\027[1m" 
+    ; _black     = lr "\027[30m"
+    ; _red       = lr "\027[31m"
+    ; _green     = lr "\027[32m"
+    ; _yellow    = lr "\027[33m"
+    ; _blue      = lr "\027[34m"
+    ; _magenta   = lr "\027[35m"
+    ; _cyan      = lr "\027[36m"
+    ; _grey      = lr "\027[37m"
+    }
+
+let determine_output_driver out_channel = 
+    try
+        ignore (Unix.getenv "OPIFEX_NOCOLORS");
+        raw_output_driver
+    with
+        | Not_found -> 
+            if Unix.isatty (Unix.descr_of_out_channel out_channel)
+                then
+                    tty_output_driver
+                else
+                    raw_output_driver
+
+
+let output_driver = ref (determine_output_driver stdout)
+
+let emph    s = (!output_driver)._emph s
+let yellow  s = (!output_driver)._yellow s
+let blue    s = (!output_driver)._blue s
+let red     s = (!output_driver)._red s
+let green   s = (!output_driver)._green s
+let cyan    s = (!output_driver)._cyan s
+let black   s = (!output_driver)._black s
+let magenta s = (!output_driver)._magenta s
+let grey    s = (!output_driver)._grey s
+
+

source/Utilities/Util.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+(*********************************************************************************************************************
+ * UTIL
+ ********************************************************************************************************************)
+
+open Batteries
+
+let concat_strings = List.fold_left (^) ""
+
+let concat_intersperse' ch = function
+    | [] ->
+        []
+
+    | (s::ss) ->
+        List.fold_left (fun a b -> a @ ch @ b) s ss
+
+let concat_intersperse ch = function
+    | [] ->
+        ""
+
+    | (s::ss) ->
+        List.fold_left (fun a b -> a ^ ch ^ b) s ss
+
+let concat_words = concat_intersperse " "
+
+let concat_lines = concat_intersperse "\n"
+
+let compose f g x = f (g x)
+
+let _print_strings f = concat_strings %> f
+let _print_words   f = concat_words %> f
+
+let print_strings_ln = _print_strings print_endline
+let print_strings    = _print_strings print_string
+
+let print_words_ln   = _print_words print_endline
+let print_words      = _print_words print_string
+
+let print_lines      = concat_lines %> print_endline
+
+let rec concat_map f = List.map f %> List.concat
+
+let list_of_hashtbl hashtbl = 
+    Hashtbl.fold (fun k v aux -> (k,v)::aux) hashtbl []
+
+let increment_ref_ r =
+    r := succ !r
+
+let increment_ref r =
+    let value = !r in
+    increment_ref_ r;
+    value
+
+let uncurry f (a,b) = f a b
+
+let curry f a b = f (a,b)
+
+let when0 pred f x =
+    if pred then f x else x
+
+let until0 pred = when0 (not pred)
+
+let when1 pred f x = when0 (pred x)
+
+let until1 pred    = when1 (not %> pred)
+
+let apply f x = f x
+
+let revapply x f = f x
+
+let applies_from_left fs x = List.fold_left revapply x fs
+
+let applies_from_right fs x = List.fold_right apply fs x
+
+let rec iter_until_ok f = function
+    | [] ->
+        0
+    | x::xs ->
+        let r = f x in
+        if r = 0 then
+            iter_until_ok f xs
+        else
+            r
+
+let marshal hint f x =
+    let fname = "marshal." ^ hint ^ ".dump" in
+    let h     = open_out fname in
+    let res   = f x in
+    Marshal.to_channel h res [];
+    res
+
+let unmarshal hint =
+    let fname = "marshal." ^ hint ^ ".dump" in
+    let h     = open_in fname in
+    Marshal.from_channel h
+
+
+type ('a,'b) either
+    = Left of 'a
+    | Right of 'b
+
+
+let container_from_list add empty xs =
+    List.fold_right add xs empty 
+
+module ExtSet (M : Set.S) = struct
+    include M
+
+    let from_list = container_from_list M.add M.empty
+
+    let diff_list s xs = List.fold_left (fun set x -> remove x set) s xs
+
+    let to_list set = fold (fun elt aux -> elt::aux) set []
+end
+
+module ExtMap (M : Map.S) = struct
+    include M
+
+    let diff m1 m2 = 
+        let f k v m =
+            M.remove k m
+            in
+        M.fold f m2 m1
+
+    let diff_list m1 xs =
+        let f k m =
+            M.remove k m
+            in
+        List.fold_right f xs m1
+
+end
+
+let call_command cmd parameters =
+    let command = String.concat " " (cmd :: parameters) in
+    Log.debug "Calling command: %s" command;
+    let exit_code = Sys.command command  in
+    if exit_code <> 0 then begin
+        Log.debug "Command %S returned with exit code %i" command exit_code;
+        Error.command_failed command
+        end
+
+
+let get_filename_base filename = 
+    try 
+        let idx = String.rindex (Filename.basename filename) '.' in
+        String.sub (Filename.basename filename) 0 idx
+    with Not_found ->
+        Filename.basename filename
+
+let get_filename_with_suffix suffix filename =
+    get_filename_base filename ^ suffix
+
+
+let cartesian_product_2 = List.cartesian_product
+
+let cartesian_product_3 xs1 xs2 xs3 =
+    let cart = cartesian_product_2 xs1 xs2 in
+    let fix (a,b) c = (a,b,c) in
+    concat_map (fun p -> List.map (fix p) xs3) cart
+
+let cartesian_product_4 xs1 xs2 xs3 xs4 =
+    let cart = cartesian_product_3 xs1 xs2 xs3 in
+    let fix (a,b,c) d = (a,b,c,d) in
+    concat_map (fun p -> List.map (fix p) xs4) cart
 #<Lib.cmxa>: use_util
 #<Lang.cmxa>: use_util, use_lib
 
-"Util": include
+"Utilities": include
 "Predefined": include
 "Languages" : include
 "Libraries" : include