-
Notifications
You must be signed in to change notification settings - Fork 125
/
dbGen_common.ml
207 lines (169 loc) · 6.32 KB
/
dbGen_common.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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
(*
Copyright © 2011, 2012 MLstate
This file is part of Opa.
Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
module Arg = Base.Arg
let version = 9 (* Should be the same as in db3/Dbgraph *)
type path = string list
(** The typing of edges out of sets (aka multi nodes) *)
type multi_key =
| Kint (** for intmaps *)
| Kstring (** for stringmaps *)
| Kfields of string list list (** for sets indexed by key (possibly multiple) *)
(** Edges of the schema *)
type edge_label =
| Multi_edge of multi_key (** indexing keys for sets (aka primary keys) *)
| Hidden_edge (** for hidden maps *)
| SumCase of int (** cases in a sum type ; as for fields, the int should be a unique id *)
| Field of string * int (** records, tuples, ... ; the int is the index in the implementation *)
type leaf =
| Leaf_int
| Leaf_float
| Leaf_text
| Leaf_binary
(** Nodes of the schema *)
type node_label =
| Multi (** A set of data of the same type *)
| Hidden (** A multi node that is implicit wrt to paths (for flattened rec types...) *)
| Sum (** A data belonging to one of several record types *)
| Product (** A record *)
| Leaf of leaf (** A simply typed data *)
type schema_edge = { label: edge_label; is_main: bool }
type schema_node = {
from_package : ObjectFiles.package_name;
nodeid : string; (* = string_of_int(n)^package_name (except "root" and "dead") *)
nlabel : node_label;
ty : QmlAst.ty;
default : QmlAst.expr option;
constraints : QmlAst.expr QmlAst.Db.db_constraint list;
context : QmlError.context;
plain : bool;
}
type engine = [ `db3 | `mongo | `dropbox]
module Args = struct
type options = {
engine : engine
}
let default = {
engine = `mongo
}
let descr = function
| `db3 -> "Db3"
| `mongo -> "Mongo"
| `dropbox -> "Dropbox"
let assoc = [("mongo", `mongo); ("db3", `db3); ("dropbox", `dropbox)]
let r = ref None
let options = [
("--database", Arg.spec_fun_of_assoc
(fun s -> r := Some {engine=s}) assoc,
" Select kind of database (db3|mongo|dropbox)");
]
let get_engine () = Option.map (fun r -> r.engine) !r
end
let get_default () =
(Option.default {Args.engine = Args.default.Args.engine} !Args.r).Args.engine
let get_engine, set_engine =
let engine = ref None in
(fun () -> Option.default (get_default ()) !engine),
(fun e -> engine := Some e)
let settyp, typ =
let typ = ref (function _ ->
OManager.i_error "Function for name -> TypeIdent.t translation is not initialized") in
(function f -> typ := f),
(function s -> !typ s)
(* type of sets stored in the database *)
let tydbset ty tyengine = QmlAst.TypeName ([ty; tyengine], Ident.source(Opacapi.Types.dbset))
(** Extract the type inside a dbset type [get_dbset_ty(dbset(t)) = t]. *)
let get_dbset_ty = function
| QmlAst.TypeName ([x; _], _id) ->
x
| ty -> OManager.i_error "Wait a dbset type receive : %a" QmlPrint.pp#ty ty
let firstclass_path_tyid () =
typ OptionalOpacapi.Types.path_t
let val_p_tyid () =
typ OptionalOpacapi.Types.path_val_p
let ref_p_tyid () =
typ OptionalOpacapi.Types.path_ref_p
let val_path_ty ty =
QmlAst.TypeName ([QmlAst.TypeName ([],val_p_tyid ()); ty],
firstclass_path_tyid ())
let get_val_path_ty = function
| QmlAst.TypeName ([_; rty], _) -> rty
| ty -> OManager.error "Type of val_path seems malformed : %a"
QmlPrint.pp#ty ty
let ref_path_ty ty =
QmlAst.TypeName ([QmlAst.TypeName ([],ref_p_tyid ()); ty],
firstclass_path_tyid ())
let db3set_engine_ty ty =
QmlAst.TypeName ([ty], typ OptionalOpacapi.Types.Db3Set.engine)
let iter ty =
QmlAst.TypeName ([ty], Ident.source Opacapi.Types.iter)
let val_v_tyid () =
typ OptionalOpacapi.Types.virtual_val_path
let ref_v_tyid () =
typ OptionalOpacapi.Types.virtual_ref_path
(** Construct type [virtual_val_path('a, rty)]*)
let virtual_val_path_ty rty =
QmlAst.TypeName ([rty], val_v_tyid ())
(** Construct type [virtual_ref_path('a, rty, wty)]*)
let virtual_ref_path_ty rty wty =
QmlAst.TypeName ([rty; wty], ref_v_tyid ())
let engine_opt opts =
match Base.List.filter_map (function `engine e -> Some e | _ -> None) opts with
| [engine] -> engine
| [] -> `db3 None (* default engine, if any requested *)
| _::_ -> failwith "Ambiguous database engine specification"
(* Common database type beetween different backends *)
module Db = struct
let t ?(engine=get_engine()) () =
let ident =
match engine with
| `db3 -> OptionalOpacapi.Types.Db3.t
| `mongo -> Opacapi.Types.DbMongo.t
| `dropbox -> Opacapi.Types.DbDropbox.t
in
QmlAst.TypeName ([], typ ident)
let set ?(engine=get_engine()) ty =
let ident =
match engine with
| `db3 -> OptionalOpacapi.Types.db3set
| `mongo -> Opacapi.Types.DbMongoSet.t
| `dropbox -> Opacapi.Types.dbdropboxset
in
QmlAst.TypeName ([ty], typ ident)
let mongo_engine () =
QmlAst.TypeName ([], typ Opacapi.Types.DbMongo.engine)
let dropbox_engine () =
QmlAst.TypeName ([], typ Opacapi.Types.DbDropbox.engine)
let ref_path_ty tydata =
let tyengine =
match get_engine() with
| `db3 -> ref_path_ty tydata
| `dropbox -> dropbox_engine ()
| `mongo -> mongo_engine ()
in
QmlAst.TypeName ([tydata; tyengine],
(* typ don't use typ with type defined inside stdlib.core*)
QmlAst.TypeIdent.of_string Opacapi.Types.Db.ref_path
)
let val_path_ty tydata =
let tyengine =
match get_engine() with
| `db3 -> val_path_ty tydata
| `dropbox -> dropbox_engine ()
| `mongo -> mongo_engine ()
in
QmlAst.TypeName ([tydata; tyengine],
(* typ don't use typ with type defined inside stdlib.core*)
QmlAst.TypeIdent.of_string Opacapi.Types.Db.val_path
)
end