cduce.ml 11.7 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
let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
26

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 34 35 36 37
let rec is_abstraction = function
  | Ast.Abstraction _ -> true
  | Ast.LocatedExpr (_,e) -> is_abstraction e
  | _ -> false

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

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

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

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

52 53 54 55
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

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

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

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

160

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

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

208

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

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

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

277
let topinput = run Parser.top_phrases
278

279 280
ifdef ML_INTERFACE then 
  let check_ml cu id out_dir out =
281 282
    let fnam = String.copy cu in
    String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
283
    try
284
      let name = fnam ^ ".cmi" in
285 286 287 288 289 290
      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
291 292 293 294
      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
295
      Ml_generator.ML.generate fmt cu ml_cu cd_cu;
296
      close_out out;
297 298
    with Not_found -> ( 
      let name = fnam ^ ".mli" in
299
      let has_cmi = List.exists (
300 301
	fun dir -> Sys.file_exists ( Filename.concat dir name )
      ) !Librarian.obj_path in
302 303 304 305
      if has_cmi then 
	Format.eprintf 
	  "Warning: found %s.mli but no %s.cmi: forgotten compilation?@." 
	  fnam fnam;
306
    )
307 308 309
else 
  let check_ml cu id out_dir out = ();;

310
let compile src out_dir =
311
  try
312 313 314 315 316 317 318 319 320
    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
321
    Librarian.compile !verbose id src;
322
    Librarian.save id out;
323
    check_ml cu id out_dir out;
324
    exit 0
325 326
  with exn -> catch_exn Format.err_formatter exn; exit 1
  
327
let compile_run src =
328
  try
329 330 331 332
    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
333
    Librarian.compile !verbose id src;
334
    Librarian.run id
335
  with exn -> catch_exn Format.err_formatter exn; exit 1
336

337
let run obj =  
338
  try
339
    if not (Filename.check_suffix obj ".cdo") || (Filename.basename obj <> obj)
340 341 342
    then raise (InvalidObjectFilename obj);
    let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
343
    Librarian.import_and_run id
344
  with exn -> catch_exn Format.err_formatter exn; exit 1
345

346 347

let dump_env ppf = dump_env ppf !typing_env !compile_env