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
[%%metapackage metapp]
[%%metadir "traverse_meta/.traverse_meta.objs/byte/"]
[%%metaflag "-open", "Stdcompat"]
module Applicative = struct
include Interface
module Make (Applicative : Modules.Applicative.S) : InstanceS
with module Applicative = Applicative = struct
module Applicative = Applicative
let instance () =
[%meta
Traverse_meta.newtypes Traverse_meta.ti [%expr
A (
let module M = struct
module Applicative = Applicative
[%%meta Metapp.Stri.of_list
(List.init Traverse_meta.variable_count (fun i ->
let ti = Traverse_meta.ti i in
let ti_t = Traverse_meta.ti_t i in
Metapp.Stri.of_list [
Ppxlib.Ast_helper.Str.type_ Nonrecursive
[Ppxlib.Ast_helper.Type.mk (Metapp.mkloc ti)
~manifest:(Traverse_meta.type_of_string ti);
Ppxlib.Ast_helper.Type.mk (Metapp.mkloc ti_t)
~manifest:
[%type: [%meta Traverse_meta.type_of_string ti]
Applicative.t]];
Ppxlib.Ast_helper.Str.value Nonrecursive
[Ppxlib.Ast_helper.Vb.mk
[%pat? ([%meta Metapp.Pat.var (Traverse_meta.eqi i)] :
([%meta Traverse_meta.type_of_string ti]
Applicative.t,
[%meta Traverse_meta.type_of_string ti_t]) eq)]
[%expr Eq]]]))]
end in
(module M))]]
end
let iter () =
let module M = Make (Modules.Applicative.Iter) in
M.instance ()
let map () =
let module M = Make (Modules.Applicative.Map) in
M.instance ()
let reduce (type m) (monoid : m Modules.Monoid.t) =
let module Monoid = (val monoid) in
let module M = Make (Modules.Applicative.Reduce (Monoid)) in
M.instance
[%%metadef
let param modname k =
let tim i = Traverse_meta.ti_t i ^ modname in
Traverse_meta.newtypes tim [%expr fun (m :
[%meta Traverse_meta.mk_t (fun i ->
(Traverse_meta.type_of_string (Traverse_meta.ti i),
Traverse_meta.type_of_string (tim i)))]) ->
let A m = m () in
[%meta Ppxlib.Ast_helper.Exp.letmodule
(Metapp.mkloc (Metapp.module_name_of_string_option (Some modname)))
(Ppxlib.Ast_helper.Mod.unpack [%expr m])
(Traverse_meta.compose (fun i acc ->
[%expr let Eq = [%meta Ppxlib.Ast_helper.Exp.ident (Metapp.mkloc
(Longident.Ldot (Lident modname, Traverse_meta.eqi i)))] in
[%meta acc]])
(k tim))]]]
let env (type env) =
[%meta Traverse_meta.newtypes Traverse_meta.ti
(param "Base" (fun tib -> [%expr
let module E = struct
type t = env
end in
let module M =
Make (Modules.Applicative.Env (E) (Base.Applicative)) in
(M.instance :
[%meta Traverse_meta.mk_t (fun i ->
(Traverse_meta.type_of_string (Traverse_meta.ti i), [%type: env ->
[%meta Traverse_meta.type_of_string (tib i)]]))])]))]
let fold (type acc) () =
let module Accu = struct
type t = acc
end in
let module M = Make (Modules.Applicative.Fold (Accu)) in
M.instance ()
let pair =
[%meta Traverse_meta.newtypes Traverse_meta.ti
(param "U" (fun tiu -> param "V" (fun tiv -> [%expr
let module M =
Make (Modules.Applicative.Pair
(U.Applicative) (V.Applicative)) in
(M.instance : [%meta Traverse_meta.mk_t (fun i ->
(Traverse_meta.type_of_string (Traverse_meta.ti i),
[%type:
[%meta Traverse_meta.type_of_string (tiu i)] *
[%meta Traverse_meta.type_of_string (tiv i)]]))])])))]
let forall () =
let module M = Make (Modules.Applicative.Forall) in
M.instance ()
let exists () =
let module M = Make (Modules.Applicative.Exists) in
M.instance ()
let option = [%meta Traverse_meta.newtypes Traverse_meta.ti (param "Base"
(fun tib -> [%expr
let module M =
Make (Modules.Applicative.Option (Base.Applicative)) in
(M.instance : [%meta Traverse_meta.mk_t (fun i ->
(Traverse_meta.type_of_string (Traverse_meta.ti i),
[%type: [%meta Traverse_meta.type_of_string (tib i)] option]))])]))]
let result (type err) =
[%meta Traverse_meta.newtypes Traverse_meta.ti (param "Base"
(fun tib -> [%expr
let module Err = struct
type t = err
end in
let module M =
Make (Modules.Applicative.Result (Base.Applicative) (Err)) in
(M.instance :
[%meta Traverse_meta.mk_t (fun i ->
(Traverse_meta.type_of_string (Traverse_meta.ti i), [%type:
([%meta Traverse_meta.type_of_string (tib i)], err)
result]))])]))]
let list =
[%meta Traverse_meta.newtypes Traverse_meta.ti (param "Base"
(fun tib -> [%expr
let module M =
Make (Modules.Applicative.List (Base.Applicative)) in
(M.instance : [%meta Traverse_meta.mk_t (fun i ->
(Traverse_meta.type_of_string (Traverse_meta.ti i),
[%type: [%meta Traverse_meta.type_of_string (tib i)] list]))])]))]
end