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 24
let compile_env = State.ref "Cduce.compile_env" Compile.empty

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

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

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

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

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

55 56 57 58
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

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

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

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

159

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

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

207

208 209 210 211 212 213 214 215 216 217
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 ->
218
      Schema_common.print_schema ppf (Typer.get_schema schema);
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 251 252 253 254 255 256
      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
257

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

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

276
let script = run Parser.prog
277
let topinput = run Parser.top_phrases
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 id src;
291
    Librarian.save id out;
292
    exit 0
293 294 295
  with exn -> catch_exn Format.err_formatter exn; exit 1
  
let compile_run src argv =
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 id src;
302 303
    Librarian.run argv id
  with exn -> catch_exn Format.err_formatter exn; exit 1
304 305

let run obj argv =  
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 312 313
    Librarian.import id;
    Librarian.run argv id
  with exn -> catch_exn Format.err_formatter exn; exit 1
314

315 316

let dump_env ppf = dump_env ppf !typing_env !compile_env