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

4
5
6
exception InvalidInputFilename of string
exception InvalidObjectFilename of string

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

11
12
13
14
15
16
17
18
(* 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

19
let toplevel = ref false
20
let verbose = ref false
21

22
let typing_env = State.ref "Cduce.typing_env" Builtin.env
23
let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
24

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

let get_global_type v =
  Typer.find_value v !typing_env
30

31
32
33
34
35
let rec is_abstraction = function
  | Ast.Abstraction _ -> true
  | Ast.LocatedExpr (_,e) -> is_abstraction e
  | _ -> false

36
let print_norm ppf d = 
37
  Location.protect ppf 
38
    (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
39

40
41
42
43
let print_sample ppf s =
  Location.protect ppf
    (fun ppf -> Sample.print ppf s)

44
45
46
let print_protect ppf s =
  Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)

47
48
let print_value ppf v =
  Location.protect ppf (fun ppf -> Value.print ppf v)
49

50
51
52
53
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

54
55
56
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;
57
  Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
58
    Ns.InternalPrinter.dump;
59
  Format.fprintf ppf "Schemas: %s@."
60
    (String.concat " " (List.map U.get_str (Typer.get_schema_names ())));
61
  Format.fprintf ppf "Values:@.";
62
63
  Typer.iter_values tenv
    (fun x t -> dump_value ppf x t (get_global_value cenv x))
64

65
66
67
let directive_help ppf =
  Format.fprintf ppf
"Toplevel directives:
68
69
70
71
72
73
74
75
  #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>;;
76
77
"

78
let rec print_exn ppf = function
79
80
  | Location (loc, w, exn) ->
      Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
81
      Format.fprintf ppf "%a" Location.html_hilight (loc,w); 
82
      print_exn ppf exn
83
  | Value.CDuceExn v ->
84
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
85
        print_value v
86
  | Typer.WrongLabel (t,l) ->
87
      Format.fprintf ppf "Wrong record selection; field %a " 
88
        Label.print (LabelPool.value l);
89
      Format.fprintf ppf "not present in an expression of type:@.%a@."
90
        print_norm t
91
  | Typer.ShouldHave (t,msg) ->
92
      Format.fprintf ppf "This expression should have type:@.%a@.%a@." 
93
        print_norm t
94
        print_protect msg
95
  | Typer.ShouldHave2 (t1,msg,t2) ->
96
      Format.fprintf ppf "This expression should have type:@.%a@.%a %a@." 
97
        print_norm t1
98
        print_protect msg
99
        print_norm t2
100
  | Typer.Error s ->
101
      Format.fprintf ppf "%a@." print_protect s
102
  | Typer.Constraint (s,t) ->
103
      Format.fprintf ppf "This expression should have type:@.%a@." 
104
        print_norm t;
105
      Format.fprintf ppf "but its inferred type is:@.%a@." 
106
        print_norm s;
107
      Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@." 
108
	print_sample (Sample.get (Types.diff s t))
109
  | Typer.NonExhaustive t ->
110
111
      Format.fprintf ppf "This pattern matching is not exhaustive@.";
      Format.fprintf ppf "Residual type:@.%a@."
112
	print_norm t;
113
      Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
114
115
116
  | 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 "")
117
118
119
120
  | Typer.UnboundExtId (cu,x) ->
      Format.fprintf ppf "Unbound external identifier %a:%a@." 
	U.print (Types.CompUnit.value cu)
	U.print (Id.value x)
121
122
123
124
  | 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
125
  | Parser.Error s | Stream.Error s -> 
126
      Format.fprintf ppf "Parsing error: %a@." print_protect s
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
  | 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:@.";
147
      Format.fprintf ppf "Object filename must have extension .cdo and no path@.";
148
149
150
151
  | Librarian.InvalidObject f ->
      Format.fprintf ppf "Invalid object file %s@." f
  | Librarian.CannotOpen f ->
      Format.fprintf ppf "Cannot open file %s@." f
152
  | Location.Generic s ->
153
      Format.fprintf ppf "%a@." print_protect s
154
  | exn ->
155
(*      raise exn *)
156
      Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
157

158

159
160
let eval_quiet tenv cenv e = 
  let (e,_) = Typer.type_expr tenv e in
161
  let e = Compile.compile_expr cenv e in 
162
163
  Eval.expr e

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

206

207
208
209
210
211
212
213
214
215
216
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 ->
217
      Schema_common.print_schema ppf (Typer.get_schema schema);
218
219
220
221
222
223
224
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
      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) 
251
      ~loading:Librarian.import_and_run
252
253
254
255
      ~directive:(directive ppf)
      !typing_env !compile_env phs in
  typing_env := tenv;
  compile_env := cenv
256

257
258
259
let catch_exn ppf_err exn =
  if not catch_exceptions then raise exn;
  match exn with
260
261
262
263
264
265
266
267
  | (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 =
268
269
  try Parser.localize_exn (fun () -> rule input)
  with e -> Parser.sync (); raise e
270

271
let run rule ppf ppf_err input =
272
  try phrases ppf (parse rule input); true
273
  with exn -> catch_exn ppf_err exn; false
274

275
let topinput = run Parser.top_phrases
276
let script = run Parser.prog
277

278

279
let compile src out_dir =
280
  try
281
282
283
284
285
286
287
288
289
    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
290
    Librarian.compile !verbose cu id src;
291
    Librarian.save cu id out;
292
    exit 0
293
294
  with exn -> catch_exn Format.err_formatter exn; exit 1
  
295
let compile_run src =
296
  try
297
298
299
300
    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
301
    Librarian.compile !verbose cu id src;
302
    Librarian.run id
303
  with exn -> catch_exn Format.err_formatter exn; exit 1
304

305
let run obj =  
306
  try
307
    if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
308
309
310
    then raise (InvalidObjectFilename obj);
    let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
311
    Librarian.import_and_run id
312
  with exn -> catch_exn Format.err_formatter exn; exit 1
313

314
315

let dump_env ppf = dump_env ppf !typing_env !compile_env