path: root/libs/util.ml

open Unix
open Lexing

(* Small things *)

let ord_couple (a, b) = if a < b then a, b else b, a

(* uniq_sorted : 'a list -> 'a list *)
let rec uniq_sorted = function
  | [] -> []
  | [a] -> [a]
  | a::b::q when a = b -> uniq_sorted (b::q)
  | a::r -> a::(uniq_sorted r)

(* list_fold_op : ('a -> 'a -> 'a) -> 'a list -> 'a *)
let rec list_fold_op op = function
  | [] -> invalid_arg "list_fold_op on empty list"
  | [a] -> a
  | x::q -> op x (list_fold_op op q)


(* Either type *)

type ('a, 'b) either =
  | Left of 'a
  | Right of 'b


(* Locations *)

type position = Lexing.position
let position_unknown = Lexing.dummy_pos

type extent = position * position
let extent_unknown = (position_unknown, position_unknown)

let string_of_position p =
  Printf.sprintf "%s:%i:%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol)
    
let string_of_extent (p,q) =
  if p.pos_fname = q.pos_fname then
    if p.pos_lnum = q.pos_lnum then
      if p.pos_cnum = q.pos_cnum then
        Printf.sprintf "%s:%i.%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol)
      else
        Printf.sprintf "%s:%i.%i-%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (q.pos_cnum - q.pos_bol)
    else
      Printf.sprintf "%s:%i.%i-%i.%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) q.pos_lnum (q.pos_cnum - q.pos_bol)
  else
    Printf.sprintf "%s:%i.%i-%s:%i.%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) q.pos_fname q.pos_lnum (q.pos_cnum - q.pos_bol)


(* Exceptions *)

exception NoLocError of string
let error x = raise (NoLocError x)

exception LocError of extent list * string
let loc_error l f x =
  try f x with
  | NoLocError e -> raise (LocError([l], e))
  | LocError(q, e) -> raise (LocError(l::q, e))

let not_implemented e = error ("Not implemented: " ^ e)

(* Varmaps *)

module VarMap = Mapext.Make(String)
let disjoint_union k a b = match a, b with
  | Some x, None -> Some x
  | None, Some y -> Some y 
  | _ -> error ("Duplicate name in disjoint union: " ^ k)

module SSet = Set.Make(String)

(* Fixpoint *)

let rec fix equal f s =
  let fs = f s in
  if equal fs s
    then fs
    else fix equal f fs

let (@@) f x = f x

let print_list f sep fmt l =
  let rec aux = function
    | [] -> ()
    | [a] -> f fmt a
    | a::b -> f fmt a; Format.fprintf fmt "%s@," sep; aux b
  in
  aux l

let uid =
  let c = ref 0 in
  fun () -> c := !c + 1; string_of_int !c


(* String *)

let is_suffix s sf =
  let n = String.length s in
  let k = String.length sf in
  n >= k && sf = String.sub s (n-k) k


(* Time heavy functions *)

let times_k : (string, float) Hashtbl.t = Hashtbl.create 10

let time id f =
  let t0 = Unix.times () in
  let result = f () in
  let t1 = Unix.times () in
  let t = t1.tms_utime -. t0.tms_utime in
  let r = try Hashtbl.find times_k id with _ -> 0. in
  Hashtbl.replace times_k id (r +. t);
  result

let show_times () =
  Format.printf "Times:@.";
  Hashtbl.iter
    (fun id t -> Format.printf "%s: %f@." id t)
    times_k