Source file `utils.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
(*

  Tools

*)

(* (@@) is too strong *)
external ( & ) : ('a -> 'b) -> 'a -> 'b = "%apply"

let (!!%) = Format.eprintf

let flip f x y = f y x
let flip2 f x y z = f z x y

module Format = struct
  include Format

  type t = formatter

  let sprintf fmt =
    let buf = Buffer.create 100 in
    let ppf = formatter_of_buffer buf in
    kfprintf (fun ppf -> pp_print_flush ppf (); Buffer.contents buf) ppf fmt

  let ksprintf f fmt =
    let buf = Buffer.create 100 in
    let ppf = formatter_of_buffer buf in
    kfprintf (fun ppf -> pp_print_flush ppf (); f (Buffer.contents buf)) ppf fmt

  let wrapf left right ppf fmt =
    left ppf;
    kfprintf right ppf fmt
end

module Option = struct
  let map f = function
    | None -> None
    | Some v -> Some (f v)

  open Format
  let format f ppf = function
    | None -> pp_print_string ppf "None"
    | Some v -> fprintf ppf "@[<2>Some@ (@[%a@])@]" f v

  let to_list = function
    | Some x -> [x]
    | None -> []
end

module List = struct
  include List

  let rec filter_map f = function
    | [] -> []
    | x :: xs -> match f x with
      | None -> filter_map f xs
      | Some y -> y :: filter_map f xs

  let concat_map f xs = concat (map f xs)

  let assoc_opt x xs = try Some (assoc x xs) with _ -> None

  let partition_map f xs =
    let rec part left right = function
      | [] -> rev left, rev right
      | x::xs ->
          match f x with
          | `Left v -> part (v::left) right xs
          | `Right v -> part left (v::right) xs
    in
    part [] [] xs

  open Format
  let rec format (sep : (unit, formatter, unit) format)  f ppf = function
    | [] -> ()
    | [x] -> f ppf x
    | x::xs ->
        fprintf ppf "@[%a@]%t%a"
        f x
        (fun ppf -> fprintf ppf sep)
        (format sep f) xs

  let from_to f t =
    (* CR jfuruse: we should build from 'to' *)
    let rec from_to st f t =
      if f > t then rev st
      else from_to (f::st) (f+1) t
    in
    from_to [] f t
end

module String = struct
  include String
  let is_prefix p s = try sub s 0 (length p) = p with _ -> false
end

module Hashtbl = struct
  include Hashtbl
  let to_list tbl = Hashtbl.fold (fun k v st -> (k,v) :: st) tbl []
end

module Filename = struct
  include Filename
  let split_extension s =
    let open String in
    try
      let pos = rindex s '.' in
      sub s 0 pos, sub s pos (length s - pos)
    with
    | _ -> s, ""
end

let protect f = try Ok (f ()) with e -> Error e

let unprotect = function
  | Ok v -> v
  | Error e -> raise e

let warnf fmt =
  let open Format in
  wrapf
    (fun ppf -> fprintf ppf "@[<2>Warning: ")
    (fun ppf -> fprintf ppf "@]@.")
    err_formatter fmt

let raise_errorf = Location.raise_errorf