Source file helpers.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
open Ppxlib
open Ast_helper

let fresh_variable =
  let next_fresh_var = ref 0 in
  fun () ->
    incr next_fresh_var;
    let str = "ppx_monad_var_" ^ (string_of_int !next_fresh_var) in
    let loc = !default_loc in
    Pat.var { txt = str; loc },
    Exp.ident { txt = Longident.Lident str; loc }

let rec first = function
  | [] -> None
  | None :: rest -> first rest
  | Some res :: _ -> Some res

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

let (<$>) = option_map

let does_not_support ?(ppx_name="This PPX") feature =
  Location.raise_errorf "%s does not support %s"
    ppx_name feature

let unwrap_or_does_not_support ?ppx_name feature = function
  | Some x -> x
  | _ -> does_not_support ?ppx_name feature

let first_or_does_not_support ?ppx_name feature options =
  unwrap_or_does_not_support ?ppx_name feature (first options)

let assert_or_does_not_support ?ppx_name feature bool =
  if not bool then does_not_support ?ppx_name feature

let add_catchall_if_needed ~loc ?mk_return cases =
  let is_catchall case =
    let rec is_pat_catchall pat =
      match pat.ppat_desc with
      | Ppat_any | Ppat_var _ -> true
      | Ppat_alias (pat, _) | Ppat_constraint (pat,_) -> is_pat_catchall pat
      | _ -> false
    in
    case.pc_guard = None
    && is_pat_catchall case.pc_lhs
  in
  if List.exists is_catchall cases then
    cases
  else
    match mk_return with
    | None -> does_not_support "cases without catch-all"
    | Some mk_return ->
      cases @ [Exp.case [%pat? any] (mk_return ~loc [%expr any])]