Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 256 lines (229 sloc) 9.618 kb
fccc685 Initial open-source release
MLstate authored
1 (*
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 module List = BaseList
21
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
22 module DbSchema = QmlDbGen.Schema
23
fccc685 Initial open-source release
MLstate authored
24 module Arg =
25 struct
26 module A = Base.Arg
27
28 (* overriding db options *)
29 let commandline_override =
30 ref (StringListMap.empty : QmlAst.Db.options list StringListMap.t)
31
32 let parse_opts s =
33 try
34 let (engine, arg) = BaseString.split_char '(' s in
35 let arg = if arg = "" then arg else BaseString.remove_prefix "\"" arg in
36 let arg = if arg = "" then arg else BaseString.remove_suffix "\")" arg in
37 let arg_opt = if arg = "" then None else Some arg in
38 match engine with
39 | "local" -> [`engine (`db3 arg_opt)]
f764139 @nrs135 [feature] Badop_light: Attempt at OPA integration (partially success…
nrs135 authored
40 | "light" -> [`engine (`db3light arg_opt)]
fccc685 Initial open-source release
MLstate authored
41 | "meta" -> [`engine `meta]
42 | "shared" ->
43 let (hostname, port) = BaseString.split_char ':' arg in
44 let hostname = if hostname = "" then None else Some hostname in
45 let port = if port = "" then None else Some (int_of_string port) in
46 [`engine (`client (hostname, port))]
47 | _ -> failwith "bad engine"
48 with
49 | Not_found
50 | Failure _ -> failwith "The syntax of database options should be as in source code, e.g., --database 'db1:\"@local(./file)\"'."
51
52 (* display enforce output *)
53 let export_schema = (Hashtbl.create 1 : (string option,string) Hashtbl.t) (* db_name -> file *)
54 let output_schema = ref false
55
56 let options = [
57
ccded04 @BourgerieQuentin [enhance] compiler: (big) added mongo accessors generation + database…
BourgerieQuentin authored
58 (* "--database", *)
59 (* A.String (fun s -> *)
60 (* try *)
61 (* let (name, opt_string) = BaseString.split_char '@' s in *)
62 (* let point = *)
63 (* if name = "" then [] *)
64 (* else [BaseString.remove_suffix ":" name] *)
65 (* in *)
66 (* let opts = parse_opts opt_string in *)
67 (* commandline_override := *)
68 (* StringListMap.add point opts !commandline_override; *)
69 (* () *)
70 (* with *)
71 (* | Not_found -> failwith "Separate the name of the database and the options with a colon, e.g., --database 'db1:\"@shared(:4849)\"'." *)
72 (* ), *)
73 (* " Override options of a database"; *)
fccc685 Initial open-source release
MLstate authored
74
75 "--export-db-schema",
76 A.String (fun s ->
77 let db,file = if String.contains s ':' then Base.String.split_char ':' s else "",s in
78 Hashtbl.add export_schema (if db = "" then None else Some db) file),
79 " Exports the database schema to the given file (format depends on the extension: use gml for manipulating it with opa-db-tool, or dot (the default) for display). Use [database_name]:file_name if you have multiple databases.";
80
81 "--print-dbschema",
82 A.Set output_schema,
83 " Dump the db-schema using the track system" ;
84
85 ]
86 end
87
88 (*
89 The name of the file where to output the schema.
90 <!> keep synchro with opatrack
91 *)
92 let schema_filename = "schema"
93
94 (* displaying the schema if asked, and fork for seeing it with display if asked *)
95 let auto_disp_schema schema =
96 if !Arg.output_schema then
97 try
98 let pp fmt schema =
99 QmlDbGen.Schema.to_dot schema fmt
100 in
101 let filename = schema_filename in
102 ignore (PassTracker.file ~filename pp schema)
103 with
104 | e ->
105 OManager.warning ~wclass:WarningClass.dbgen_schema
978b7c4 @akoprow [fix] typo: occurence->occurrence, occured->occurred
akoprow authored
106 "@[<2> An error occurred while trying to display the output the db schema@\n%s@]"
fccc685 Initial open-source release
MLstate authored
107 (Printexc.to_string e)
108 else
109 if ObjectFiles.compilation_mode() = `init then (* Only export the full schema, ie after `init *)
110 Hashtbl.iter
111 (fun db filename ->
112 try
113 let ch = open_out filename in
114 if Base.String.is_suffix ".gml" filename
115 then QmlDbGen.Schema.db_to_gml schema db ch
116 else QmlDbGen.Schema.db_to_dot schema db ch;
117 close_out ch
118 with
119 | Not_found ->
120 OManager.warning ~wclass:WarningClass.dbgen_schema
121 "@[<2> Could not dump the database schema: database \"%s\" not found@]"
122 (Option.default "<default>" db)
123 | Sys_error msg ->
124 OManager.warning ~wclass:WarningClass.dbgen_schema
125 "@[<2> Could not open file for outputting the database schema%s@\n%s@]"
126 (match db with Some db -> " of database "^db | None -> "")
127 msg)
128 Arg.export_schema
129
130 (* separation *)
131 module S =
132 struct
133 type t = QmlDbGen.Schema.t
134 let pass = "pass_DbSchemaGeneration"
135 let pp f _ = Format.pp_print_string f "<dummy>"
136 end
137 module R = ObjectFiles.Make(S)
138
139 let process_code gamma _annotmap schema code =
140 assert(schema == QmlDbGen.Schema.initial);
141
142 (* getting the schema of other packages *)
143 let merge package schema1 schema2 =
144 (* UNNEEDED: because the types aren't supposed to contain type variables
145 let schema2 = QmlDbGen.Schema.map_types (QmlRefresh.refresh_typevars_from_ty package) schema2 in *)
146 let schema2 = QmlDbGen.Schema.map_expr (QmlRefresh.refresh_expr_no_annotmap package) schema2 in
147 (* let oc1 = open_out ("schema1"^(fst package)) in *)
148 (* let _ = QmlDbGen.Schema.to_dot schema1 oc1 in *)
149 (* let oc2 = open_out ("schema2"^(fst package)) in *)
150 (* let _ = QmlDbGen.Schema.to_dot schema2 oc2 in *)
151 let merged_schema = QmlDbGen.Schema.merge schema1 schema2 in
152 (* let oc3 = open_out ("schema3"^(fst package)) in *)
153 (* let _ = QmlDbGen.Schema.to_dot merged_schema oc3 in *)
154 (* let _ = close_out oc1; close_out oc2; close_out oc3 in *)
155 merged_schema
156 in
157 let schema =
158 if ObjectFiles.compilation_mode() = `init
159 then
160 let sch = R.fold_with_name ~packages:true ~deep:true merge schema in
161 sch
162 else R.fold_with_name merge schema
163 in
164 (* registering Database definitions
165 The construction of the schema needs to get
166 Database nodes before NewDbValue.
167 *)
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
168 let schema =
fccc685 Initial open-source release
MLstate authored
169 List.fold_left
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
170 (fun schema code_elt ->
fccc685 Initial open-source release
MLstate authored
171 match code_elt with
172 | QmlAst.Database (label, ident, p, opts) ->
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
173 QmlDbGen.Schema.register_db_declaration schema (label, ident, p, opts)
174 | _ -> schema
175 ) schema code in
fccc685 Initial open-source release
MLstate authored
176 (* registering NewDbValue definitions *)
177 let schema, code =
178 List.fold_left_collect (
179 fun schema code_elt ->
180 match code_elt with
181 | QmlAst.NewDbValue (label, value) ->
182 let schema, o =
183 QmlDbGen.Schema.register_new_db_value ~name_default_values:true
184 schema gamma (label, value) in
185 let code =
186 match o with
187 | Some (binding, value) ->
188 let code_elt = QmlAst.NewVal (Annot.refresh label, [binding]) in
189 [code_elt; QmlAst.NewDbValue (label, value)]
190 | None -> [code_elt] in
191 schema, code
192 | _ -> schema, [code_elt]
193 ) schema code in
194
195 (* modify by commandline options: *)
196 let schema =
197 let override point (ident, db_options) =
198 if StringListMap.mem point !Arg.commandline_override then begin
199 let opts = StringListMap.find point !Arg.commandline_override in
200 Arg.commandline_override :=
201 StringListMap.remove point !Arg.commandline_override;
202 (ident, opts)
203 end else begin
204 (ident, db_options)
205 end
206 in
207 let schema = QmlDbGen.Schema.mapi override schema in
208 if StringListMap.is_empty !Arg.commandline_override then schema
209 else begin
210 let (key, _) = StringListMap.min !Arg.commandline_override in
211 match key with
212 | [] -> failwith "No anonymous database declared in the source code."
213 | l ->
214 let n = String.concat "/" l in
215 let msg = Printf.sprintf "No database with name '%s' declared." n in
216 failwith msg (* TODO: register the error somewhere *)
217 end
218 in
219
220 (* finalizing the schema *)
221 let schema, partial_schema =
222 match QmlDbGen.Schema.finalize schema with
223 | Some schema ->
224 schema,
225 QmlDbGen.Schema.of_package schema (ObjectFiles.get_current_package_name())
226 | None -> schema, schema (* empty schemas *)
227 in
228
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
229 (* updating gamma with registered databases *)
230 let gamma =
231 match ObjectFiles.compilation_mode () with
232 | `init -> gamma
233 | _ ->
1b343b3 @BourgerieQuentin [fix] compiler, database: export database ident into gamma only for d…
BourgerieQuentin authored
234 let current = ObjectFiles.get_current_package_name () in
235 List.fold_left
236 (fun gamma database ->
237 if database.DbSchema.package = current then
238 let ty = fst (QmlTypes.type_of_type gamma (database.DbSchema.dbty)) in
239 let _ =
240 #<If:DBGEN_DEBUG>
241 OManager.printf "Adding database (%a) %a to gamma\n%!"
242 QmlPrint.pp#ty ty
243 QmlPrint.pp#ident database.DbSchema.ident
244 #<End>;
245 in
246 QmlTypes.Env.Ident.add database.DbSchema.ident (QmlTypes.Scheme.quantify ty) gamma
247 else gamma
248 ) gamma (DbSchema.get_db_declaration schema)
4b041c8 @BourgerieQuentin [fix] compiler, database: Adding all database ident to gamma, even if…
BourgerieQuentin authored
249 in
250
fccc685 Initial open-source release
MLstate authored
251 let _ = R.save partial_schema in
252
253 let _ = auto_disp_schema schema in
254
255 (gamma, schema, code)
Something went wrong with that request. Please try again.