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
|
(* 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 = "Typeable"
let runtimename = "Deriving_Typeable"
let default_module = Some "Defaults"
let alpha = None
let allow_private = true
let predefs = [
["int"], ["Deriving_Typeable";"int"];
["bool"], ["Deriving_Typeable";"bool"];
["unit"], ["Deriving_Typeable";"unit"];
["char"], ["Deriving_Typeable";"char"];
["int32"], ["Deriving_Typeable";"int32"];
["Int32";"t"], ["Deriving_Typeable";"int32"];
["int64"], ["Deriving_Typeable";"int64"];
["Int64";"t"], ["Deriving_Typeable";"int64"];
["nativeint"], ["Deriving_Typeable";"nativeint"];
["float"], ["Deriving_Typeable";"float"];
["num"], ["Deriving_num";"num"];
["string"], ["Deriving_Typeable";"string"];
["list"], ["Deriving_Typeable";"list"];
["ref"], ["Deriving_Typeable";"ref"];
["option"], ["Deriving_Typeable";"option"];
]
let depends = []
end
module Builder(Generator : Defs.Generator) = struct
open Generator.Loc
open Camlp4.PreCast
open Description
module Helpers = Generator.AstHelpers
let mkName tname =
let file_name, sl, _, _, _, _, _, _ = Loc.to_tuple _loc in
Printf.sprintf "%s_%d_%f_%s" file_name sl (Unix.gettimeofday ()) tname
let wrap type_rep = [ <:str_item< let type_rep = lazy $type_rep$ >> ]
let generator = (object(self)
inherit Generator.generator
method proxy () =
None, [ <:ident< type_rep >>;
<:ident< has_type >>;
<:ident< cast >>;
<:ident< throwing_cast >>;
<:ident< make_dynamic >>;
<:ident< mk >>;
]
method tuple ctxt ts =
let params =
List.map (fun t -> <:expr< $self#call_expr ctxt t "type_rep"$ >>) ts in
wrap <:expr< $uid:runtimename$.TypeRep.mkTuple $Helpers.expr_list params$ >>
method gen ?eq ctxt tname params constraints =
let paramList =
List.fold_right
(fun p cdr ->
<:expr< $self#call_expr ctxt p "type_rep"$ :: $cdr$ >>)
params
<:expr< [] >> in
wrap <:expr< $uid:runtimename$.TypeRep.mkFresh $str:mkName tname$ $paramList$ >>
method sum ?eq ctxt tname params constraints _ =
self#gen ~eq ctxt tname params constraints
method record ?eq ctxt tname params constraints _ =
self#gen ~eq ctxt tname params constraints
method variant ctxt tname params constraints (_,tags) =
let tags, extends =
List.fold_left
(fun (tags, extends) -> function
| Type.Tag (l, []) -> <:expr< ($str:l$, None) :: $tags$ >>, extends
| Type.Tag (l, ts) ->
<:expr< ($str:l$, Some $self#call_expr ctxt (`Tuple ts) "type_rep"$) ::$tags$ >>,
extends
| Type.Extends t ->
tags,
<:expr< $self#call_expr ctxt t "type_rep"$::$extends$ >>)
(<:expr< [] >>, <:expr< [] >>) tags in
wrap <:expr< $uid:runtimename$.TypeRep.mkPolyv $tags$ $extends$ >>
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
include Base.RegisterFullClass(Description)(Builder)
|
