Source file ppx_diff.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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
open Base
open Ppxlib
open Shared

let check_no_custom_how_to_diff_on_equal_to ~equal_to ~builder =
  let (_ : unit Type_kind.core option) =
    Option.map
      equal_to
      ~f:
        (Type_kind.map_core ~f:(function
          | None -> ()
          | Some how_to_diff ->
            let open (val builder : Builder.S) in
            raise_error
              (Printf.sprintf
                 {|%s will be ignored.
On types like
   type t = some_other_type = repeated type definion
custom %s attributes are only allowed on the repeated type definition
                  |}
                 (How_to_diff.Custom.to_attribute_string how_to_diff)
                 Shared.name_of_ppx)))
  in
  ()
;;

let create_default ~context ~kind_to_diff : Diff.t =
  let { Context.builder; _ } = context in
  let create_core = Diff_core.create ~context in
  let open (val builder : Builder.S) in
  match (kind_to_diff : How_to_diff.t Type_kind.t) with
  | Core core -> create_core core |> Core_diff.to_diff
  | Abstract -> Diff_abstract.diff
  | Record { fields; local; equal_to } ->
    check_no_custom_how_to_diff_on_equal_to ~equal_to ~builder;
    Diff_record.create_record ~record_fields:fields ~local ~builder ~create_core
  | Variant { rows; equal_to } ->
    check_no_custom_how_to_diff_on_equal_to ~equal_to ~builder;
    Diff_variant.create rows ~context ~create_core
;;

let generate context type_to_diff_declaration ~how_to_diff : Items.t =
  let { Context.builder; sig_or_struct; _ } = context in
  let open (val builder : Builder.S) in
  let { Type_declaration.kind = kind_to_diff; name = _; params = _; unboxed = _ } =
    type_to_diff_declaration
  in
  let diff =
    match how_to_diff with
    | None -> create_default ~context ~kind_to_diff
    | Some atomic ->
      Diff_atomic.create ~type_to_diff_declaration ~atomic ~builder ~sig_or_struct
  in
  let prefix =
    { Items.sig_items = [%sig: open! Diffable.For_ppx]
    ; struct_items = Ok [%str open! Diffable.For_ppx]
    }
  in
  let type_to_diff_declaration =
    Type_declaration.map type_to_diff_declaration ~f:(fun _ -> ())
  in
  diff |> Diff.add_prefix ~prefix |> Diff.to_module ~context ~type_to_diff_declaration
;;

let validate_rec_flag (td : How_to_diff.t Type_declaration.t) rec_flag ~builder =
  match rec_flag with
  | Recursive -> ()
  | Nonrecursive ->
    (match td.kind with
     | Type_kind.Core (Constr { type_name; module_ = None; _ }, _)
       when Type_name.( = ) type_name td.name -> ()
     | _ ->
       (* [nonrec] won't work for most types. E.g.
          {[
            type t = int [@@deriving diff]

            module M = struct
              type nonrec t = t * string [@@deriving_inline diff]

              module Diff = struct
                type derived_on = t
                type t = (t, string, Diff.t, Diff_of_string.t) Tuple2.Diff.t

                                                                 ...
              end
            end
          ]}

          will result in "type declaration is cyclic"

          But even writing

          {[ module Diff = struct
               type derived_on = t
               type nonrec t = (t, string, Diff.t, Diff_of_string.t) Tuple2.Diff.t
             end
          ]}

          would not be enough, because the [t] in [(t, string, ...)] is the wrong [t].

          We run into similar problems with e.g. [type nonrec t = t option] or
          [type nonrec t = | X | Y of t]
       *)
       let open (val builder : Builder.S) in
       raise_error
         "[nonrec] is only supported for types that look like [type (?params) \
          [type_name] = (?params) [type_name]], e.g. [type nonrec t = t] or [type nonrec \
          x = x] or [type nonrec 'a t = 'a t] or [type nonrec 'a t = ('a, int) t] etc.")
;;

let generator sig_or_struct ~f =
  Deriving.Generator.make
    Deriving.Args.(
      empty
      +> arg How_to_diff.Label.how (Ast_pattern.estring __)
      +> arg How_to_diff.Label.key How_to_diff.Type_.pattern
      +> arg How_to_diff.Label.elt How_to_diff.Type_.pattern
      +> What_to_derive.Extra.arg
      +> arg "stable_version" (Ast_pattern.eint __))
    (fun ~(loc : Location.t)
         ~path:(_ : string)
         ((rec_flag : rec_flag), (type_declarations : type_declaration list))
         how
         key
         elt
         extra_derive
         stable_version ->
      let (builder : Builder.t) =
        Builder.create
          (module struct
            include (val Ast_builder.make loc)
            include (val Ppxlib_jane.Ast_builder.make loc)
          end)
      in
      let how_to_diff = How_to_diff.Maybe_abstract.create ~how ~key ~elt ~builder in
      let open (val builder : Builder.S) in
      let td =
        match type_declarations with
        | [] | _ :: _ :: _ -> raise_error "multiple type declarations are not supported"
        | [ td ] -> td
      in
      let type_to_diff_declaration, how_to_diff =
        Type_declaration.create td ~how_to_diff ~builder
      in
      (match really_recursive rec_flag type_declarations with
       | Recursive ->
         (match how_to_diff with
          | Some (_ : How_to_diff.Atomic.t) -> ()
          | _ -> raise_error "recursive types are not supported (except for atomic diffs)")
       | Nonrecursive -> validate_rec_flag type_to_diff_declaration rec_flag ~builder);
      let what_to_derive =
        What_to_derive.create ?extra:extra_derive td how_to_diff sig_or_struct ~builder
      in
      let context =
        { Context.builder
        ; what_to_derive
        ; all_params = type_to_diff_declaration.params
        ; sig_or_struct
        ; stable_version = Option.map stable_version ~f:(Stable_version.of_int ~builder)
        }
      in
      let t = generate context type_to_diff_declaration ~how_to_diff in
      f t ~builder)
;;

module Gen_sig = struct
  let generator = generator `sig_ ~f:(fun items ~builder:_ -> items.sig_items)
end

module Gen_struct = struct
  let generator =
    generator `struct_ ~f:(fun items ~builder ->
      match items.Items.struct_items with
      | Ok items -> items
      | Error error ->
        let open (val builder : Builder.S) in
        raise_error (Error.to_string_mach error))
  ;;
end

let () =
  Deriving.add
    name_of_ppx
    ~str_type_decl:Gen_struct.generator
    ~sig_type_decl:Gen_sig.generator
  |> Deriving.ignore
;;