Source file `ppx_matches.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
open! Ppxlib
open! Ast_builder.Default
module List = ListLabels

let ppx_namespace = "ppx_matches"
let pp_quoted pp ppf = Format.fprintf ppf "`%a`" pp
let raise_errorf ~loc fmt = Location.raise_errorf ~loc ("%s: " ^^ fmt) ppx_namespace

module Matches = struct
  let is_binding_var var = not (String.starts_with ~prefix:"_" var.txt)

  let rec is_binding_pattern pat =
    match pat.ppat_desc with
    | Ppat_any -> false
    | Ppat_var var -> is_binding_var var
    | Ppat_alias (pat, var) -> is_binding_pattern pat || is_binding_var var
    | Ppat_array pats | Ppat_tuple pats -> List.exists pats ~f:is_binding_pattern
    | Ppat_interval _ | Ppat_constant _ -> false
    | Ppat_construct (_, None) | Ppat_variant (_, None) -> false
    | Ppat_construct (_, Some (_, pat)) | Ppat_variant (_, Some pat) ->
      is_binding_pattern pat
    | Ppat_record (fields, _) ->
      List.exists fields ~f:(fun (_field, pat) -> is_binding_pattern pat)
    | Ppat_or (pat1, pat2) -> is_binding_pattern pat1 || is_binding_pattern pat2
    | Ppat_constraint (pat, _type) -> is_binding_pattern pat
    | Ppat_type _type_ident -> true
    | Ppat_lazy pat -> is_binding_pattern pat
    | Ppat_unpack mod_ident -> Option.is_some mod_ident.txt
    | Ppat_exception pat -> is_binding_pattern pat
    | Ppat_extension _ ->
      (* Overapproximation. User's ppx extension *may* bind patterns once extended *)
      true
    | Ppat_open (_mod_ident, pat) -> is_binding_pattern pat
  ;;

  let assert_pat_is_not_binding ~loc pat =
    if is_binding_pattern pat
    then
      raise_errorf
        ~loc
        "invalid [%%matches? ...] payload. Pattern %a cannot bind any variables."
        (pp_quoted Pprintast.pattern)
        pat
  ;;

  let expand_inline ~loc matchee pat ?when_ () =
    match when_ with
    | None ->
      assert_pat_is_not_binding ~loc pat;
      (* Disable redundant case warning *)
      [%expr
        begin[@warning "-11"] match [%e matchee] with
        | [%p pat] -> true
        | _ -> false
        end]
    | Some when_ ->
      [%expr
        begin[@warning "-11"] match [%e matchee] with
        | [%p pat] when [%e when_] -> true
        | _ -> false
        end]
  ;;

  let expand ~loc pat ?when_ () =
    match when_ with
    | None ->
      assert_pat_is_not_binding ~loc pat;
      [%expr
        function[@warning "-11"]
        | [%p pat] -> true
        | _ -> false]
    | Some when_ ->
      [%expr
        function[@warning "-11"]
        | [%p pat] when [%e when_] -> true
        | _ -> false]
  ;;
end

let impl : structure -> structure =
  object
    inherit Ast_traverse.map as super

    method! expression expr =
      let loc = expr.pexp_loc in
      match expr with
      | [%expr [%matches? [%p? pat]] [%e? matchee]] ->
        Matches.expand_inline ~loc matchee pat ()
      | [%expr [%matches? [%p? pat] when [%e? when_]] [%e? matchee]] ->
        Matches.expand_inline ~loc matchee pat ~when_ ()
      | [%expr [%matches? [%p? pat]]] -> Matches.expand ~loc pat ()
      | [%expr [%matches? [%p? pat] when [%e? when_]]] ->
        Matches.expand ~loc pat ~when_ ()
      | expr -> super#expression expr
  end
    #structure
;;

let () =
  Reserved_namespaces.reserve ppx_namespace;
  Driver.register_transformation ~impl ppx_namespace
;;