path: root/src/tools.ml

(*
This file is part of licht.

licht 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 3 of the License, or
(at your option) any later version.

licht 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 licht.  If not, see <http://www.gnu.org/licenses/>.
*)

let u = UTF8.from_utf8string

module Option = struct

  let map f = function
  | Some x -> Some (f x)
  | None -> None

  let iter f = function
  | Some x -> f x
  | None -> ()

  let bind f = function
  | None -> None
  | Some x -> f x

  let default v = function
  | None -> v
  | Some x -> x

  let test f v = begin
  match f v with
  | Some x -> x
  | None -> v
  end


end

module String = struct

  include String

  let split str ~by:sep = begin
    let p = String.index str sep in
    let slen = String.length str in
    String.sub str 0 p, String.sub str (p + 1) (slen - p - 1)
  end

  let string_of_ints v = begin
    let buff = Buffer.create 1 in
    let rec convert value = begin
      Buffer.add_char buff @@ char_of_int @@ value land 0xFF;
      let rem = value lsr 8 in
      match rem with
      | 0 -> Buffer.contents buff
      | x -> (convert[@tailcall]) x
    end in
    let res = convert v in
    let buff' = Buffer.create @@ String.length res in
    for i = ((String.length res) - 1) downto 0 do
      Buffer.add_char buff' @@ String.get res i
    done;
    Buffer.contents buff'
  end

  let print_buffer f t = begin
    let buff = UTF8.Buffer.create 16 in
    f buff t;
    UTF8.Buffer.contents buff
  end

  let filter_float str = begin
    let l = String.length str in
    if l > 0 && String.get str (l - 1) = '.' then
      String.sub str 0 (l - 1)
    else
      str
  end

end

module List = struct

  (** fold_left over only the first element *)
  let fst f init = function
  | hd::tl -> f init hd
  | [] -> init

  let printb ?(first=(u"(")) ?(last=(u")")) ?(sep=(u",")) f buffer elems = begin

    let rec print = begin function
    | [] -> ()
    | hd::[] ->
        f buffer hd;
    | hd::tl ->
        f buffer hd;
        UTF8.Buffer.add_string buffer sep;
        (print[@tailcall]) tl
    end in

    UTF8.Buffer.add_string buffer first;
    print elems;
    UTF8.Buffer.add_string buffer last
  end

  let rec find_map f = begin function
  | [] -> raise Not_found
  | hd::tl -> begin match f hd with
              | Some x -> x
              | None -> (find_map[@tailcall]) f tl
              end
  end

  and find_map2 p = begin function
  | [] -> raise Not_found
  | x::l ->
    begin try find_map p x with
      Not_found -> (find_map2[@tailcall]) p l
    end
  end

end

module Tuple2 = struct

  let fst = Pervasives.fst

  let snd = Pervasives.snd

  let map1 f (a, b) = (f a, b)

  let map2 f (a, b) = (a, f b)

  let replace1 v (a, b) = (v, b)

  let replace2 v (a, b) = (a, v)

  let printb ?(first="(") ?(last=")") ?(sep=",") format1 format2 out (a, b) = begin
    UTF8.Printf.bprintf out "%s%a%s%a%s"
      first
      format1 a
      sep
      format2 b
      last
  end

end

module NCurses = struct

  type mouse_event =
  | BUTTON1_PRESSED
  | BUTTON1_RELEASED
  | BUTTON1_CLICKED
  | BUTTON1_DOUBLE_CLICKED
  | BUTTON1_TRIPLE_CLICKED
  | BUTTON2_PRESSED
  | BUTTON2_RELEASED
  | BUTTON2_CLICKED
  | BUTTON2_DOUBLE_CLICKED
  | BUTTON2_TRIPLE_CLICKED
  | BUTTON3_PRESSED
  | BUTTON3_RELEASED
  | BUTTON3_CLICKED
  | BUTTON3_DOUBLE_CLICKED
  | BUTTON3_TRIPLE_CLICKED
  | BUTTON4_PRESSED
  | BUTTON4_RELEASED
  | BUTTON4_CLICKED
  | BUTTON4_DOUBLE_CLICKED
  | BUTTON4_TRIPLE_CLICKED
  | BUTTON_SHIFT
  | BUTTON_CTRL
  | BUTTON_ALT
  | ALL_MOUSE_EVENTS
  | REPORT_MOUSE_POSITION

  type event_type

  external set_mouse_event: mouse_event list -> unit = "c_set_mouse_event"

  external get_mouse_event: unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event"

  external is_event_of_type: mouse_event -> event_type -> bool = "c_is_event_of_type"

end

let try_finally f except =
  try let res = f () in
    except ();
    res
  with e ->
    except ();
    raise e

type (_,_) cmp =
  | Eq : ('a,'a) cmp
  | Lt : ('a,'b) cmp
  | Gt : ('a,'b) cmp

(** Existencial type for comparing two types.
    This type has no utility, except for structural comparison between two
    values.
 *)
type existencial = Ex: 'a -> existencial

module type COMPARABLE_TYPE = sig

    type 'a t

    val comp: 'a t -> 'b t -> ('a, 'b) cmp

end

let fold_for f a b init =
  let rec _fold res i = begin
  if i >= b then res
  else
    _fold (f i res) (i + 1)
  end in
  (_fold[@tailcall]) init a