cduce.ml 8.05 KB
Newer Older
1 2
open Location

3 4
let quiet = ref false

5 6 7 8
let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
let glb_env = State.ref "Cduce.glb_env" Typer.Env.empty
let eval_env = Eval.global_env

9
let print_norm ppf d = 
10
  Location.protect ppf 
11
    (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
12 13 14

let print_value ppf v =
  Location.protect ppf (fun ppf -> Value.print ppf v)
15

16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
let dump_env ppf =
  Format.fprintf ppf "Global types:";
  Typer.Env.iter (fun x _ -> Format.fprintf ppf " %s" x) !glb_env;
  Format.fprintf ppf ".@\n";
  Eval.Env.iter 
    (fun x v ->
       let t = Typer.Env.find x !typing_env in
       Format.fprintf ppf "@[|- %s : %a@ => %a@]@\n"
	 x
	 print_norm t
	 print_value v
    )
    !eval_env
  

31
let rec print_exn ppf = function
32
  | Location (loc, exn) ->
33
      Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
34
      Format.fprintf ppf "%a" Location.html_hilight loc;
35
      print_exn ppf exn
36 37
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
38
        print_value v
39 40
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
41
        (Types.LabelPool.value l);
42
      Format.fprintf ppf "applied to an expression of type %a@\n"
43
        print_norm t
44 45
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
46
        (Types.LabelPool.value l);
47 48
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
49
        print_norm t
50
        msg
51
  | Typer.Constraint (s,t,msg) ->
52
      Format.fprintf ppf "This expression should have type %a@\n" 
53
        print_norm t;
54
      Format.fprintf ppf "but its infered type is: %a@\n" 
55
        print_norm s;
56
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
57
	Types.Sample.print (Types.Sample.get (Types.diff s t));
58
      Format.fprintf ppf "%s@\n" msg
59 60 61
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
62
	print_norm t;
63
      Format.fprintf ppf "Sample value: %a@\n" 
64
	Types.Sample.print (Types.Sample.get t)
65 66
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
67 68 69 70 71 72 73 74
  | Wlexer.Illegal_character c ->
      Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c)
  | Wlexer.Unterminated_comment ->
      Format.fprintf ppf "Comment not terminated@\n"
  | Wlexer.Unterminated_string ->
      Format.fprintf ppf "String literal not terminated@\n"
  | Wlexer.Unterminated_string_in_comment ->
      Format.fprintf ppf "This comment contains an unterminated string literal@\n"
75
  | Parser.Error s | Stream.Error s -> 
76
      Format.fprintf ppf "Parsing error: %s@\n" s
77 78
  | Location.Generic s ->
      Format.fprintf ppf "%s@\n" s
79
  | exn ->
80 81
      raise exn
(*
82
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
83
*)
84

85
let debug ppf = function
86 87
  | `Filter (t,p) -> 
      Format.fprintf ppf "[DEBUG:filter]@\n";
88 89
      let t = Typer.typ !glb_env t
      and p = Typer.pat !glb_env p in
90 91
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
92
		   Format.fprintf ppf " %s:%a@\n" x
93
		     print_norm (Types.descr t)) f
94 95
  | `Compile2 (t,pl) -> 
      Format.fprintf ppf "[DEBUG:compile2]@\n";
96 97 98 99 100 101 102 103
(*      let t = Types.descr (Typer.typ !glb_env t) in
      let pl = List.map (fun p -> 
			   let p = Typer.pat !glb_env p in
			   let a = Types.descr (Patterns.accept p) in
			   (Some p, Types.cap a t)) pl in
      let d = Patterns.Compiler.make_dispatcher t pl in
      Patterns.Compiler.print_disp ppf d *)
      ()
104

105 106
  | `Accept p ->
      Format.fprintf ppf "[DEBUG:accept]@\n";
107
      let p = Typer.pat !glb_env p in
108 109 110 111
      let t = Patterns.accept p in
      Format.fprintf ppf " %a@\n" Types.Print.print t
  | `Compile (t,pl) ->
      Format.fprintf ppf "[DEBUG:compile]@\n";
112 113
      let t = Typer.typ !glb_env t
      and pl = List.map (Typer.pat !glb_env) pl in
114
      Patterns.Compile.debug_compile ppf t pl
115 116
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
117
      let t = Types.Record.get (Types.descr (Typer.typ !glb_env t)) in
118
      match Types.Record.first_label t with
119 120 121 122
	    | `Fail -> Format.fprintf ppf "Empty@\n"
	    | `Success -> Format.fprintf ppf "{ }@\n"
	    | `NoField -> Format.fprintf ppf "{| |}@\n"
	    | `SomeField -> Format.fprintf ppf "{ } \ {| |}@\n"
123 124
	    | `Label l ->
		let (pr,ab) = Types.Record.normal' t l in
125
		Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
126 127 128
		List.iter (fun (d,n) ->
			     Format.fprintf ppf "%a => @[%a@];@\n"
			     Types.Print.print_descr d
129
			     Types.Print.print_descr (Types.Record.descr n)
130 131 132
			  ) pr;
		Format.fprintf ppf "@] Absent: @[%a@])@\n" 
		  Types.Print.print_descr 
133
		  (Types.Record.descr ab)
134 135 136
(*
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
137
      let t = Types.descr (Typer.typ !glb_env t) in
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
      let r = Types.Record.normal t in
      let count = ref 0 and seen = ref [] in
      let rec aux ppf x =
	try 
	  let no = List.assq x !seen in
	  Format.fprintf ppf "[[%i]]" no
	with Not_found ->
	  incr count;
	  seen := (x, !count) :: !seen;
	  Format.fprintf ppf "[[%i]]:" !count;
	  match x with
	    | `Success -> Format.fprintf ppf "Success"
	    | `Fail -> Format.fprintf ppf "Fail"
	    | `Label (l,pr,ab) ->
		Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
		List.iter (fun (d,n) ->
			     Format.fprintf ppf "%a => @[%a@];@\n"
			     Types.Print.print_descr d
			     aux n
			  ) pr;
		Format.fprintf ppf "@] Absent: @[%a@])" aux ab
      in
      Format.fprintf ppf "%a@\n" aux r
*)
162 163


164

165
let mk_builtin () =
166 167 168
  let bi = List.map (fun (n,t) -> [n, mk noloc (Ast.Internal t)]) 
	     Builtin.types in
  glb_env := List.fold_left Typer.register_global_types !glb_env bi
169

170 171 172
let () = mk_builtin ()


173
let run ppf ppf_err input =
174 175 176
  let insert_type_bindings = 
    List.iter (fun (x,t) ->
		 typing_env := Typer.Env.add x t !typing_env;
177 178
		 if not !quiet then
		   Format.fprintf ppf "|- %s : %a@\n@." x print_norm t) 
179 180 181 182 183 184 185
  in
  
  let type_decl decl =
    insert_type_bindings (Typer.type_let_decl !typing_env decl)
  in

  let eval_decl decl =
186
    let bindings = Eval.eval_let_decl Eval.Env.empty decl in
187 188 189
    List.iter 
      (fun (x,v) ->
	 Eval.enter_global x v;
190 191
	 if not !quiet then
	   Format.fprintf ppf "=> %s : @[%a@]@\n@." x print_value v
192 193 194
      ) bindings
  in

195
  let phrase ph = 
196 197
    match ph.descr with
      | Ast.EvalStatement e ->
198
	  let (fv,e) = Typer.expr !glb_env e in
199
	  let t = Typer.type_check !typing_env e Types.any true in
200
	  Location.dump_loc ppf e.Typed.exp_loc;
201 202
	  if not !quiet then
	    Format.fprintf ppf "|- %a@\n@." print_norm t;
203
	  let v = Eval.eval Eval.Env.empty e in
204 205
	  if not !quiet then
	    Format.fprintf ppf "=> @[%a@]@\n@." print_value v
206 207
      | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
      | Ast.LetDecl (p,e) ->
208
	  let decl = Typer.let_decl !glb_env p e in
209 210 211 212 213 214 215 216
	  type_decl decl;
	  eval_decl decl
      | Ast.TypeDecl _ -> ()
      | Ast.Debug l -> debug ppf l
      | _ -> assert false
  in

  let do_fun_decls decls =
217
    let decls = List.map (fun (p,e) -> Typer.let_decl !glb_env p e) decls in
218 219 220
    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
    List.iter eval_decl decls
  in
221 222 223 224 225 226 227 228 229 230
  let rec phrases funs = function
    | { descr = Ast.LetDecl (p,({descr=Ast.Abstraction _} as e))} :: phs -> 
	phrases ((p,e)::funs) phs
    | ph :: phs ->
	do_fun_decls funs;
	phrase ph;
	phrases [] phs
    | _ ->
	do_fun_decls funs
  in
231
  try 
232 233 234 235 236 237
    let p = 
      try Parser.prog input
      with
	| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
	| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
    in
238
    let (type_decls,fun_decls) = 
239
      List.fold_left
240 241 242 243
	(fun ((typs,funs) as accu) ph -> match ph.descr with
	   | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
	   | Ast.LetDecl (p,({descr=Ast.Abstraction _} as e)) -> 
	       (typs, (p,e)::funs)
244
	   | _ -> accu
245
	) ([],[]) p in
246
    glb_env := Typer.register_global_types !glb_env type_decls;
247
    phrases [] p;
248
    true
249
  with 
250
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
251
	raise e  (* To get ocamlrun stack trace *)
252
    | exn -> print_exn ppf_err exn; false
253
	
254