cduce.ml 11.9 KB
Newer Older
1
open Location
2
open Ident
3

4
5
ifdef ML_INTERFACE then module ML = Ml_ocaml;;

6
7
8
exception InvalidInputFilename of string
exception InvalidObjectFilename of string

9
10
(* if set to false toplevel exception aren't cought. 
 * Useful for debugging with OCAMLRUNPARAM="b" *)
11
12
let catch_exceptions = true

13
14
15
16
17
18
19
20
(* retuns a filename without the suffix suff if any *) 
let prefix filename suff =
  if Filename.check_suffix filename suff then
    try
      Filename.chop_extension filename
    with Invalid_argument filename -> failwith "Not a point in the suffix?"
  else filename

21
let toplevel = ref false
22
let verbose = ref false
23

24
let typing_env = State.ref "Cduce.typing_env" Builtin.env
25
26
let compile_env = State.ref "Cduce.compile_env" Compile.empty

27
let get_global_value cenv v =
28
  Eval.var (Compile.find v !compile_env)
29
30
31

let get_global_type v =
  Typer.find_value v !typing_env
32

33
let enter_global_value x v t =
34
  typing_env := Typer.enter_value x t !typing_env;
35
36
  compile_env := Compile.enter_global !compile_env x; 
  Eval.push v
37
  
38
39
40
41
42
let rec is_abstraction = function
  | Ast.Abstraction _ -> true
  | Ast.LocatedExpr (_,e) -> is_abstraction e
  | _ -> false

43
let print_norm ppf d = 
44
  Location.protect ppf 
45
    (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
46

47
48
49
50
let print_sample ppf s =
  Location.protect ppf
    (fun ppf -> Sample.print ppf s)

51
52
53
let print_protect ppf s =
  Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)

54
55
let print_value ppf v =
  Location.protect ppf (fun ppf -> Value.print ppf v)
56

57
58
59
60
let dump_value ppf x t v =
  Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
    U.print (Id.value x) print_norm t print_value v

61
62
63
let dump_env ppf tenv cenv =
  Format.fprintf ppf "Types:%a@." Typer.dump_types tenv;
  Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns tenv;
64
  Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
65
    Ns.InternalPrinter.dump;
66
  Format.fprintf ppf "Schemas: %s@."
67
    (String.concat " " (List.map U.get_str (Typer.get_schema_names ())));
68
  Format.fprintf ppf "Values:@.";
69
70
  Typer.iter_values tenv
    (fun x t -> dump_value ppf x t (get_global_value cenv x))
71

72
73
74
let directive_help ppf =
  Format.fprintf ppf
"Toplevel directives:
75
76
77
78
79
80
81
82
  #quit;;                 quit the interpreter
  #env;;                  dump current environment
  #reinit_ns;;            reinitialize namespace processing
  #help;;                 shows this help message
  #dump_value <expr>;;    dump an XML-ish representation of the resulting
                          value of a given expression
  #print_schema <name>;;
  #print_type <name>;;
83
84
"

85
let rec print_exn ppf = function
86
87
  | Location (loc, w, exn) ->
      Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
88
      Format.fprintf ppf "%a" Location.html_hilight (loc,w); 
89
      print_exn ppf exn
90
  | Value.CDuceExn v ->
91
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
92
        print_value v
93
  | Typer.WrongLabel (t,l) ->
94
      Format.fprintf ppf "Wrong record selection; field %a " 
95
        Label.print (LabelPool.value l);
96
      Format.fprintf ppf "not present in an expression of type:@.%a@."
97
        print_norm t
98
  | Typer.ShouldHave (t,msg) ->
99
      Format.fprintf ppf "This expression should have type:@.%a@.%a@." 
100
        print_norm t
101
        print_protect msg
102
  | Typer.ShouldHave2 (t1,msg,t2) ->
103
      Format.fprintf ppf "This expression should have type:@.%a@.%a %a@." 
104
        print_norm t1
105
        print_protect msg
106
        print_norm t2
107
  | Typer.Error s ->
108
      Format.fprintf ppf "%a@." print_protect s
109
  | Typer.Constraint (s,t) ->
110
      Format.fprintf ppf "This expression should have type:@.%a@." 
111
        print_norm t;
112
      Format.fprintf ppf "but its inferred type is:@.%a@." 
113
        print_norm s;
114
      Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@." 
115
	print_sample (Sample.get (Types.diff s t))
116
  | Typer.NonExhaustive t ->
117
118
      Format.fprintf ppf "This pattern matching is not exhaustive@.";
      Format.fprintf ppf "Residual type:@.%a@."
119
	print_norm t;
120
      Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
121
122
123
  | Typer.UnboundId (x,tn) ->
      Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
        (if tn then " (it is a type name)" else "")
124
125
126
127
  | Typer.UnboundExtId (cu,x) ->
      Format.fprintf ppf "Unbound external identifier %a:%a@." 
	U.print (Types.CompUnit.value cu)
	U.print (Id.value x)
128
129
130
131
  | Ulexer.Error (i,j,s) ->
      let loc = Location.loc_of_pos (i,j), `Full in
      Format.fprintf ppf "Error %a:@." Location.print_loc loc;
      Format.fprintf ppf "%a%s" Location.html_hilight loc s
132
  | Parser.Error s | Stream.Error s -> 
133
      Format.fprintf ppf "Parsing error: %a@." print_protect s
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
  | Librarian.InconsistentCrc id ->
      Format.fprintf ppf "Link error:@.";
      let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
      Format.fprintf ppf "Inconsistent checksum (compilation unit: %s)@."
	name
  | Librarian.NoImplementation id ->
      Format.fprintf ppf "Link error:@.";
      let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
      Format.fprintf ppf "No implementation found for compilation unit: %s@."
	name
  | Librarian.Loop id ->
      Format.fprintf ppf "Compilation error:@.";
      let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
      Format.fprintf ppf "Loop between compilation unit (compilation unit: %s)@."
	name
  | InvalidInputFilename f ->
      Format.fprintf ppf "Compilation error:@.";
      Format.fprintf ppf "Source filename must have extension .cd@.";
  | InvalidObjectFilename f ->
      Format.fprintf ppf "Compilation error:@.";
154
      Format.fprintf ppf "Object filename must have extension .cdo and no path@.";
155
156
157
158
  | Librarian.InvalidObject f ->
      Format.fprintf ppf "Invalid object file %s@." f
  | Librarian.CannotOpen f ->
      Format.fprintf ppf "Cannot open file %s@." f
159
  | Location.Generic s ->
160
      Format.fprintf ppf "%a@." print_protect s
161
  | exn ->
162
(*      raise exn *)
163
      Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
164

165

166
167
168
let eval_quiet tenv cenv e = 
  let (e,_) = Typer.type_expr tenv e in
  let e = Compile.compile_eval cenv e in 
169
170
  Eval.expr e

171
let debug ppf tenv cenv = function
172
  | `Subtype (t1,t2) ->
173
      Format.fprintf ppf "[DEBUG:subtype]@.";
174
175
      let t1 = Types.descr (Typer.typ tenv t1)
      and t2 = Types.descr (Typer.typ tenv t2) in
176
177
      let s = Types.subtype t1 t2 in
      Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
178
  | `Sample t ->
179
180
      Format.fprintf ppf "[DEBUG:sample]@.";
      (try
181
	 let t = Types.descr (Typer.typ tenv t) in
182
183
184
	 Format.fprintf ppf "%a@." print_sample (Sample.get t)
       with Not_found ->
	 Format.fprintf ppf "Empty type : no sample !@.")
185
  | `Filter (t,p) -> 
186
      Format.fprintf ppf "[DEBUG:filter]@.";
187
188
      let t = Typer.typ tenv t
      and p = Typer.pat tenv p in
189
190
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
191
		   Format.fprintf ppf " %a:%a@." U.print (Id.value x)
192
193
		     print_norm (Types.descr t)) f
  | `Accept p ->
194
      Format.fprintf ppf "[DEBUG:accept]@.";
195
      let p = Typer.pat tenv p in
196
      let t = Patterns.accept p in
197
      Format.fprintf ppf " %a@." Types.Print.print (Types.descr t)
198
  | `Compile (t,pl) ->
199
      Format.fprintf ppf "[DEBUG:compile]@.";
200
201
      let t = Typer.typ tenv t
      and pl = List.map (Typer.pat tenv) pl in
202
      Patterns.Compile.debug_compile ppf t pl
203
204
  | `Explain (t,e) ->
      Format.fprintf ppf "[DEBUG:explain]@.";
205
206
      let t = Typer.typ tenv t in
      (match Explain.explain (Types.descr t) (eval_quiet tenv cenv e) with
207
208
209
210
211
	 | Some p ->
	     Format.fprintf ppf "Explanation: @[%a@]@." 
	       Explain.print_path p
	 | None ->
	     Format.fprintf ppf "Explanation: value has given type@.")
212

213

214
215
216
217
218
219
220
221
222
223
let flush_ppf ppf = Format.fprintf ppf "@."

let directive ppf tenv cenv = function
  | `Debug d ->
      debug ppf tenv cenv d
  | `Quit ->
      (if !toplevel then raise End_of_file)
  | `Env ->
      dump_env ppf tenv cenv
  | `Print_schema schema ->
224
      Schema_common.print_schema ppf (Typer.get_schema schema);
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
      flush_ppf ppf
  | `Print_type name ->
      Typer.dump_type ppf tenv name;
      flush_ppf ppf
  | `Print_schema_type schema_ref ->
      Typer.dump_schema_type ppf schema_ref;
      flush_ppf ppf
  | `Reinit_ns ->
      Typer.set_ns_table_for_printer tenv
  | `Help ->
      directive_help ppf
  | `Dump pexpr ->
      Value.dump_xml ppf (eval_quiet tenv cenv pexpr);
      flush_ppf ppf

let print_id_opt ppf = function
  | None -> Format.fprintf ppf "-"
  | Some id -> Format.fprintf ppf "val %a" U.print (Id.value id)

let print_value_opt ppf = function
  | None -> ()
  | Some v -> Format.fprintf ppf " = %a" print_value v

let show ppf id t v =
  Format.fprintf ppf "@[%a : @[%a%a@]@]@."
    print_id_opt id 
    print_norm t 
    print_value_opt v

let phrases ppf phs =
  let (tenv,cenv,_) = 
    Compile.comp_unit 
      ~run:true ~show:(show ppf) 
      ~loading:(fun cu -> Librarian.import cu; Librarian.run Value.nil cu)
      ~directive:(directive ppf)
      !typing_env !compile_env phs in
  typing_env := tenv;
  compile_env := cenv
263

264
265
266
let catch_exn ppf_err exn =
  if not catch_exceptions then raise exn;
  match exn with
267
268
269
270
271
272
273
274
  | (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break) 
      as e -> 
      raise e
  | exn -> 
      print_exn ppf_err exn;
      Format.fprintf ppf_err "@."

let parse rule input =
275
276
  try Parser.localize_exn (fun () -> rule input)
  with e -> Parser.sync (); raise e
277

278
let run rule ppf ppf_err input =
279
  try phrases ppf (parse rule input); true
280
  with exn -> catch_exn ppf_err exn; false
281

282
let script = run Parser.prog
283
let topinput = run Parser.top_phrases
284

285
286
ifdef ML_INTERFACE then 
  let check_ml cu id out_dir out =
287
288
    let fnam = String.copy cu in
    String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
289
    try
290
      let name = fnam ^ ".cmi" in
291
292
293
294
295
296
      let file = List.find ( 
	fun dir -> Sys.file_exists ( Filename.concat dir name ) 
      ) !Librarian.obj_path in
      if file = "" then raise Not_found;
      let file = Filename.concat file name in
      let ml_cu = ML.CompUnit.from_bytecode file cu
297
298
299
300
301
302
      and cd_cu = Ml_cduce.CompUnit.from_types_cu cu id in
      Ml_checker.run ml_cu cd_cu;
      let out = open_out ( Filename.concat out_dir (cu ^ ".ml") ) in
      let fmt = Format.formatter_of_out_channel out in
      Ml_generator.ML.generate fmt ml_cu cd_cu;
      close_out out;
303
304
    with Not_found -> ( 
      let name = fnam ^ ".mli" in
305
      let has_cmi = List.exists (
306
307
	fun dir -> Sys.file_exists ( Filename.concat dir name )
      ) !Librarian.obj_path in
308
309
310
311
      if has_cmi then 
	Format.eprintf 
	  "Warning: found %s.mli but no %s.cmi: forgotten compilation?@." 
	  fnam fnam;
312
    )
313
314
315
else 
  let check_ml cu id out_dir out = ();;

316
let compile src out_dir =
317
  try
318
319
320
321
322
323
324
325
326
    if not (Filename.check_suffix src ".cd")
    then raise (InvalidInputFilename src);
    let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
    let out_dir = 
      match out_dir with
	| None -> Filename.dirname src
	| Some x -> x in
    let out = Filename.concat out_dir (cu ^ ".cdo") in
    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
327
    Librarian.compile !verbose id src;
328
    Librarian.save id out;
329
    check_ml cu id out_dir out;
330
    exit 0
331
332
333
  with exn -> catch_exn Format.err_formatter exn; exit 1
  
let compile_run src argv =
334
  try
335
336
337
338
    if not (Filename.check_suffix src ".cd")
    then raise (InvalidInputFilename src);
    let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
339
    Librarian.compile !verbose id src;
340
341
    Librarian.run argv id
  with exn -> catch_exn Format.err_formatter exn; exit 1
342
343

let run obj argv =  
344
  try
345
    if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
346
347
348
    then raise (InvalidObjectFilename obj);
    let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
349
350
351
    Librarian.import id;
    Librarian.run argv id
  with exn -> catch_exn Format.err_formatter exn; exit 1
352

353
354

let dump_env ppf = dump_env ppf !typing_env !compile_env