Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 382 lines (279 sloc) 8.985 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
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 (* refactoring *)
21
22 (* shorthands *)
23 module D = ConsoleParser.Directive
24 module P = OpaTopProperties
25 module Format = Base.Format
26
27 type env = OpaTopEnv.env
28 type directive_action = env D.action
29 type directive = env D.directive
30
31 let std = P.stdout
32
33 (* directives *)
34 (* guidelines : alphabetic order, except for help which is at end *)
35
36 let make_manager set name =
37 let func env args =
38 let _ =
39 match args with
40 | [] -> set true
41 | [ "on" ] -> set true
42 | [ "off" ] -> set false
43 | _ -> Format.fprintf !std "use : #%s on / off@." name
44 in
45 env
46 in
47 func
48
49 (* a *)
50
51 let assert_action = make_manager P.assert_set "assert"
52 let assert_ = "#assert +\\(.+\\)$", 1, assert_action
53
54 (* b *)
55
56 let bypass_action env _ =
57 (* OpaTop.dump_bymap env ; *)
58 env
59
60 let bypass = "#bypass$", 0, bypass_action
61
62 (* d *)
63 (*
64 let dbgen_action = make_manager P.dbgen_set "dbgen"
65 let dbgen = "#dbgen +\\(.+\\)$", 1, dbgen_action
66 *)
67
68 let dddbgen_action = make_manager P.dddbgen_set "dddbgen"
69 let dddbgen = "#dddbgen +\\(.+\\)$", 1, dddbgen_action
70
71 (* e *)
72
73 let env_action env _ =
74 let iter ident ty value =
75 Format.fprintf !std "%s : %a = %a@\n"
76 (Ident.to_string ident) QmlPrint.pp#ty ty OpaTopValue.pp value
77 in
78 Format.fprintf !std "Dump environment...@\n";
79 OpaTopEnv.iter iter env;
80 Format.pp_print_flush !std ();
81 env
82
83 let env = "#env$", 0, env_action
84
85 let envgrep_action env = function
86 | [ str ] ->
87 let reg = Str.regexp (".*"^str) in
88 let iter ident ty value =
89 let out = Format.sprintf "%s : %a = %a"
90 (Ident.to_string ident) QmlPrint.pp#ty ty OpaTopValue.pp value
91 in
92 if Str.string_match reg out 0 then
93 Format.fprintf !std "%s@\n" out
94 else ()
95 in
96 Format.fprintf !std "Dump environment...@\n";
97 OpaTopEnv.iter iter env;
98 Format.pp_print_flush !std ();
99 env
100
101 | _ -> assert false
102
103 let envgrep = "#envgrep +\\(.*\\)$", 1, envgrep_action
104
105 (*
106 let eval_action = make_manager P.eval_set "eval"
107 let eval = "#eval +\\(.+\\)$", 1, eval_action
108 *)
109
110 (* i *)
111
112 let import_db_action env = function
113 | [ file ] -> (
114 Format.fprintf !std "loading the schema for database %S ...@." file;
115 (* Fixme: add warnings if there are already DB definitions / DB is already open *)
116 try
117 failwith "import-schema temporarily disabled"
118 (* let schema = QmlDbGen.DbImport.get_schema Official_database.do_simpleread_on_db file in *)
119 (* OpaTopEnv.set_schema env schema *)
120 with
121 | e ->
122 Format.fprintf !std "@[<2>cannot import database :@\n%s@]@." (Printexc.to_string e);
123 env
124 )
125 | _ -> assert false
126
127 let import_db = "#import-db +\"\\(.+\\)\"$", 1, import_db_action
128
129 (* l *)
130
131 let load_action env = function
132 | [ file ] ->
133 OpaTopEnv.input_file env file
134
135 | _ -> assert false (* regexp error *)
136
137 let load = "#load +\"\\(.+\\)\"$", 1, load_action
138
139 let lookup_action env = function
140 | [ var ] -> (
141 let var =
142 (* we don't lookup internals *)
143 Ident.source var
144 in
145 match OpaTopEnv.find_opt var env with
146 | Some (ty, value) ->
147 Format.fprintf !std "%s : %a = %a@."
148 (Ident.original_name var) QmlPrint.pp#ty ty OpaTopValue.pp value ;
149 env
150 | None ->
151 Format.fprintf !std "var %s is not in environment@." (Ident.original_name var);
152 env
153 )
154 | _ -> assert false (* regexp error *)
155
156 let lookup = "#lookup +\\(.+\\)$", 1, lookup_action
157
158 (* n *)
159
160 let noeval_action = make_manager P.noeval_set "noeval"
161 let noeval = "#noeval +\\(.+\\)$", 1, noeval_action
162
163 (* q *)
164
165 let quit_action _ _ =
166 Format.fprintf !std "quit@.";
167 exit 0
168
169 let quit = "#quit$", 0, quit_action
170
171 (* r *)
172
173 let reset_action _ _ =
174 Format.fprintf !std "Environment is reset@.";
175 OpaTopEnv.start ()
176
177 let reset = "#reset", 0, reset_action
178
179 let restricted_bypass_action = make_manager P.restricted_bypass_set "restricted-bypass"
180 let restricted_bypass = "#restricted-bypass +\\(.+\\)$", 1, restricted_bypass_action
181
182 (* s *)
183
184 let schema_action env = function
185 | [ file ] -> (
186 Format.fprintf !std "export db-schema in file %S ...@." file;
187 let schema = OpaTopEnv.schema env in
188 try
189 let oc = open_out file in
190 QmlDbGen.Schema.to_dot schema oc;
191 close_out oc;
192 let _ = Sys.command (Printf.sprintf "dot -Tpng %s | display &" file) in
193 env
194 with
195 | e ->
196 Format.fprintf !std "@[<2>cannot export schema :@\n%s@]@." (Printexc.to_string e);
197 env
198 )
199 | _ -> assert false (* regexp error *)
200
201 let schema = "#schema +\"\\(.+\\)\"$", 1, schema_action
202
203
204
205 (** {b Descr}: Stuff to enable switching between available typecheckers when
206 working in an OPA toplevel. Handles the directive forcing to use the
207 typechecker whose name is given as a string in the directive. *)
208 let set_typer_action env = function
209 | [ typer ] ->
210 (* If not typechecker is found for the given name, emit an error
211 message instead of remaining silent. *)
212 if not (OpaTopProperties.switch_typechecker typer) then
213 Format.fprintf !std "No available typechecker named \"%s\".@\n" typer ;
214 env
215 | _ -> assert false (* Regexp error *)
216
217 let set_typer = "#set-typer +\\(.+\\)$", 1, set_typer_action
218
219
220
221 (* t *)
222
223 (*
224 let typer_action = make_manager P.typer_set "typer"
225 let typer = "#typer +\\(.+\\)$", 1, typer_action
226 *)
227
228 (* FIXME : add extern types *)
229 let types_action env _ =
230 let iter _ (typescheme, visibility) =
231 match visibility with
232 | QmlAst.TDV_public ->
233 Format.fprintf !std "%a@\n" QmlPrint.pp#tsc typescheme
234 | QmlAst.TDV_private _ ->
235 Format.fprintf !std "@@private %a@\n" QmlPrint.pp#tsc typescheme
236 | QmlAst.TDV_abstract _ ->
237 Format.fprintf !std "@@abstract %a@\n" QmlPrint.pp#tsc typescheme in
238 Format.fprintf !std "Dump types definitions...@\n";
239 QmlTypes.Env.TypeIdent.iter iter (OpaTopEnv.types env).QmlTypes.gamma ;
240 Format.pp_print_flush !std () ;
241 env
242
243 let types = "#types$", 0, types_action
244
245 (* help *)
246
247 let help_action env _ =
248 let pp spec doc = Format.fprintf !std "%-32s %s@\n" spec doc in
249 Format.fprintf !std "---@\n";
250 Format.fprintf !std "@[<2>opatop directives:@\n";
251
252 (* a *)
253
254 pp "#assert on / off ;;"
255 "toggle assertion mode";
256
257 (* b *)
258
259 pp "#bypass ;;"
260 "Dump all available external primitives";
261
262 (* d *)
263
264 (* pp "#dbgen on / off ;;" *)
265 (* "Toggle DbGen mode"; *)
266
267 pp "#dddbgen on / off ;;"
268 "Toggle dump of returned dbGen code";
269
270 (* e *)
271
272 pp "#env ;;"
273 "Dump the environment (types + values)";
274
275 pp "#envgrep regexp ;;"
276 "Dump the environment combined with a grep";
277
278 (* pp "#eval on / off ;;" *)
279 (* "Toggle evaluation mode"; *)
280
281 (* h *)
282
283 pp "#help ;;"
284 "Print this help menu for directives";
285
286 (* i *)
287
288 pp "#import-db \"db_prefix\" ;;"
289 "Try to import an existing database with its definitions";
290
291 (* l *)
292
293 pp "#load \"file.opa\" ;;"
294 "Load a file";
295
296 pp "#lookup %s ;;"
297 "Find a variable in the environment";
298
299 (* n *)
300
301 pp "#noeval on / off ;;"
302 "Disable evaluation";
303
304 (* q *)
305
306 pp "#quit ;;"
307 "Quit opatop";
308
309 (* r *)
310
311 pp "#reset ;;"
312 "Reset the environment";
313
314 (* pp "#restricted_bypass on / off ;;" *)
315 (* "Toggle restricted bypass mode"; *)
316
317 (* s *)
318
319 pp "#schema \"file.dot\" ;;"
320 "Export the current db-schema in a dot format file";
321
322 Format.fprintf !std "@[<4>";
323
324 pp "#set-typer <typer> ;; "
325 "Switch the type-checker used, choose between:";
326
327 Format.fprintf !std "%a@]@\n"
328 (Format.pp_list "@ /@ " Format.pp_print_string) QmlTyper.available_typer_list;
329
330 (* t *)
331
332 (* pp "#typer on / off ;;" *)
333 (* "Toggle typer mode"; *)
334
335 pp "#types ;;"
336 "Dump types definitions from the environment";
337
338 (* extra *)
339
340 pp "[ctr] + 'c'"
341 "Interrupt";
342
343 pp "[ctr] + 'd'"
344 "Quit";
345
346
347 Format.fprintf !std "@]@\n";
348
349 (* return the env *)
350
351 env
352
353
354 let help = "#help$", 0, help_action
355
356 (* handler *)
357 (* add there all directives, in alphabetic order *)
358
359 let all_directives = [
360 assert_ ;
361 bypass ;
362 (* dbgen ; *)
363 dddbgen ;
364 env ;
365 envgrep ;
366 (* eval ; *)
367 import_db ;
368 help ;
369 load ;
370 lookup ;
371 noeval ;
372 quit ;
373 reset ;
374 restricted_bypass ;
375 schema ;
376 set_typer ;
377 types ;
378 ]
379
380 let handler =
381 List.fold_left D.add (D.empty ()) all_directives
Something went wrong with that request. Please try again.