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
|
(* Copyright Jeremy Yallop 2007.
This file is free software, distributed under the MIT license.
See the file COPYING for details.
*)
open Pa_deriving_common
open Utils
module Description : Defs.ClassDescription = struct
let classname = "Eq"
let runtimename = "Deriving_Eq"
let default_module = None
let alpha = Some "Eq_alpha"
let allow_private = true
let predefs = [
["unit"], ["Deriving_Eq";"unit"];
["bool"], ["Deriving_Eq";"bool"];
["char"], ["Deriving_Eq";"char"];
["int"], ["Deriving_Eq";"int"];
["int32"], ["Deriving_Eq";"int32"];
["Int32";"t"], ["Deriving_Eq";"int32"];
["int64"], ["Deriving_Eq";"int64"];
["Int64";"t"], ["Deriving_Eq";"int64"];
["nativeint"], ["Deriving_Eq";"nativeint"];
["float"], ["Deriving_Eq";"float"];
["num"], ["Deriving_num";"num"];
["list"], ["Deriving_Eq";"list"];
["option"], ["Deriving_Eq";"option"];
["string"], ["Deriving_Eq";"string"];
["ref"], ["Deriving_Eq";"ref"];
["array"], ["Deriving_Eq";"array"];
]
let depends = []
end
module Builder(Loc : Defs.Loc) = struct
module Helpers = Base.AstHelpers(Loc)
module Generator = Base.Generator(Loc)(Description)
open Loc
open Camlp4.PreCast
open Description
let lprefix = "l" and rprefix = "r"
let wrap eq =
[ <:str_item< let eq l r = match l, r with $list:eq$ >>]
let generator = (object (self)
method proxy unit =
None, [ <:ident< eq >>; ]
inherit Generator.generator
method tuple ctxt tys =
let n = List.length tys in
let lnames, lpatt, _ = Helpers.tuple ~param:lprefix n in
let rnames, rpatt, _ = Helpers.tuple ~param:rprefix n in
let test_and ty (lid, rid) e =
<:expr< $self#call_expr ctxt ty "eq"$ $lid:lid$ $lid:rid$ && $e$ >> in
let expr =
List.fold_right2 test_and tys (List.zip lnames rnames) <:expr< true >> in
wrap [ <:match_case< (($lpatt$),($rpatt$)) -> $expr$ >> ]
method case ctxt (name,args) =
match args with
| [] -> <:match_case< ($uid:name$, $uid:name$) -> true >>
| _ ->
let nargs = List.length args in
let _, lpatt, lexpr = Helpers.tuple ~param:lprefix nargs
and _, rpatt, rexpr = Helpers.tuple ~param:rprefix nargs in
let patt = <:patt< ($uid:name$ $lpatt$, $uid:name$ $rpatt$) >> in
let eq =
<:expr< $self#call_expr ctxt (`Tuple args) "eq"$ $lexpr$ $rexpr$ >> in
<:match_case< $patt$ -> $eq$ >>
method sum ?eq ctxt tname params constraints summands =
let wildcard =
match summands with
| [_] -> []
| _ -> [ <:match_case< _ -> false >>] in
wrap (List.map (self#case ctxt) summands @ wildcard)
method field ctxt (name, ty, mut) =
assert(mut <> `Mutable);
<:expr< $self#call_poly_expr ctxt ty "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >>
method record ?eq ctxt tname params constraints fields =
if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then
wrap [ <:match_case< (l,r) -> l==r >> ]
else
let lpatt = Helpers.record_pattern ~prefix:lprefix fields in
let rpatt = Helpers.record_pattern ~prefix:rprefix fields in
let test_and f e = <:expr< $self#field ctxt f$ && $e$ >> in
let expr = List.fold_right test_and fields <:expr< true >> in
wrap [ <:match_case< (($lpatt$), ($rpatt$)) -> $expr$ >> ]
method polycase ctxt : Pa_deriving_common.Type.tagspec -> Ast.match_case = function
| Type.Tag (name, []) -> <:match_case< `$name$, `$name$ -> true >>
| Type.Tag (name, es) ->
<:match_case< `$name$ l, `$name$ r -> $self#call_expr ctxt (`Tuple es) "eq"$ l r >>
| Type.Extends t ->
let lpatt, lguard, lcast = Generator.cast_pattern ctxt ~param:"l" t in
let rpatt, rguard, rcast = Generator.cast_pattern ctxt ~param:"r" t in
let patt = <:patt< ($lpatt$, $rpatt$) >> in
let eq = <:expr< $self#call_expr ctxt t "eq"$ $lcast$ $rcast$ >> in
<:match_case< $patt$ when $lguard$ && $rguard$ -> $eq$ >>
method variant ctxt tname params constraints (spec, tags) =
wrap (List.map (self#polycase ctxt) tags @ [ <:match_case< _ -> false >> ])
end :> Generator.generator)
let classname = Description.classname
let runtimename = Description.runtimename
let generate = Generator.generate generator
let generate_sigs = Generator.generate_sigs generator
let generate_expr = Generator.generate_expr generator
end
module Eq = Base.Register(Description)(Builder)
let depends = (module Builder : Defs.FullClassBuilder)
|
