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

4
let version = "0.0.9 (alpha)"
5

6 7
let quiet = ref false

8
let typing_env = State.ref "Cduce.typing_env" Env.empty
9

10 11
let enter_global_value x v t =
  Eval.enter_global x v;
12
  typing_env := Env.add x t !typing_env
13

14 15 16 17 18
let rec is_abstraction = function
  | Ast.Abstraction _ -> true
  | Ast.LocatedExpr (_,e) -> is_abstraction e
  | _ -> false

19
let print_norm ppf d = 
20
  Location.protect ppf 
21
    (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
22 23 24

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

26
let dump_env ppf =
27 28 29
  Format.fprintf ppf "Global types:";
  Typer.dump_global_types ppf;
  Format.fprintf ppf ".@\n";
30
  Env.iter 
31
    (fun x v ->
32
       let t = Env.find x !typing_env in
33 34
       Format.fprintf ppf "@[|- %a : %a@ => %a@]@\n"
	 U.print (Id.value x)
35 36 37
	 print_norm t
	 print_value v
    )
38
    !Eval.global_env
39 40
  

41
let rec print_exn ppf = function
42
  | Location (loc, exn) ->
43
      Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
44
      Format.fprintf ppf "%a" Location.html_hilight loc;
45
      print_exn ppf exn
46 47
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
48
        print_value v
49
  | Eval.MultipleDeclaration v ->
50 51
      Format.fprintf ppf "Multiple declaration for global value %a@\n" 
        U.print (Id.value v)
52
  | Typer.WrongLabel (t,l) ->
53 54
      Format.fprintf ppf "Wrong record selection: the label %a@\n" 
        U.print (LabelPool.value l);
55
      Format.fprintf ppf "applied to an expression of type:@\n%a@\n"
56
        print_norm t
57
  | Typer.ShouldHave (t,msg) ->
58
      Format.fprintf ppf "This expression should have type:@\n%a@\n%s@\n" 
59
        print_norm t
60
        msg
61
  | Typer.ShouldHave2 (t1,msg,t2) ->
62
      Format.fprintf ppf "This expression should have type:@\n%a@\n%s %a@\n" 
63 64 65
        print_norm t1
        msg
        print_norm t2
66 67 68
  | Typer.Error s ->
      Format.fprintf ppf "%s@\n" s
  | Typer.Constraint (s,t) ->
69
      Format.fprintf ppf "This expression should have type:@\n%a@\n" 
70
        print_norm t;
71
      Format.fprintf ppf "but its inferred type is:@\n%a@\n" 
72
        print_norm s;
73
      Format.fprintf ppf "which is not a subtype, as shown by the sample:@\n" ;
74 75
      Location.protect ppf
	(fun ppf ->
76
	   Sample.print ppf (Sample.get (Types.diff s t)));
77
      Format.fprintf ppf "@\n"
78 79
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
80
      Format.fprintf ppf "Residual type:@\n%a@\n"
81
	print_norm t;
82 83
      Format.fprintf ppf "Sample:@\n%a@\n" 
	Sample.print (Sample.get t)
84
  | Typer.UnboundId x ->
85
      Format.fprintf ppf "Unbound identifier %a@\n" U.print (Id.value x)
86 87 88 89 90 91 92 93
  | 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"
94
  | Parser.Error s | Stream.Error s -> 
95
      Format.fprintf ppf "Parsing error: %s@\n" s
96 97
  | Location.Generic s ->
      Format.fprintf ppf "%s@\n" s
98
  | exn ->
99
(*      raise exn *)
100 101
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)

102
let debug ppf = function
103 104
  | `Subtype (t1,t2) ->
      Format.fprintf ppf "[DEBUG:subtype]@\n";
105 106
      let t1 = Types.descr (Typer.typ t1)
      and t2 = Types.descr (Typer.typ t2) in
107 108
      Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
	(Types.subtype t1 t2)
109 110 111 112 113 114
  | `Sample t ->
      Format.fprintf ppf "[DEBUG:sample]@\n";
      let t = Types.descr (Typer.typ t) in
      Location.protect ppf
	(fun ppf -> Sample.print ppf (Sample.get t));
      Format.fprintf ppf "@\n"
115 116
  | `Filter (t,p) -> 
      Format.fprintf ppf "[DEBUG:filter]@\n";
117 118
      let t = Typer.typ t
      and p = Typer.pat p in
119 120
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
121
		   Format.fprintf ppf " %a:%a@\n" U.print (Id.value x)
122 123 124
		     print_norm (Types.descr t)) f
  | `Accept p ->
      Format.fprintf ppf "[DEBUG:accept]@\n";
125
      let p = Typer.pat p in
126
      let t = Patterns.accept p in
127
      Format.fprintf ppf " %a@\n" Types.Print.print (Types.descr t)
128 129
  | `Compile (t,pl) ->
      Format.fprintf ppf "[DEBUG:compile]@\n";
130 131
      let t = Typer.typ t
      and pl = List.map Typer.pat pl in
132
      Patterns.Compile.debug_compile ppf t pl
133 134


135

136 137


138
let run ppf ppf_err input =
139 140
  let insert_type_bindings = 
    List.iter (fun (x,t) ->
141
		 typing_env := Env.add x t !typing_env;
142
		 if not !quiet then
143
		   Format.fprintf ppf "|- %a : %a@\n@." U.print (Id.value x) print_norm t) 
144 145 146
  in
  
  let type_decl decl =
147 148
    insert_type_bindings (Typer.type_let_decl !typing_env decl);
    Typer.report_unused_branches ()
149 150 151
  in

  let eval_decl decl =
152
    let bindings = Eval.eval_let_decl Env.empty decl in
153 154 155
    List.iter 
      (fun (x,v) ->
	 Eval.enter_global x v;
156
	 if not !quiet then
157
	   Format.fprintf ppf "=> %a : @[%a@]@\n@." U.print (Id.value x) print_value v
158 159 160
      ) bindings
  in

161
  let phrase ph = 
162 163
    match ph.descr with
      | Ast.EvalStatement e ->
164
	  let (fv,e) = Typer.expr e in
165
	  let t = Typer.type_check !typing_env e Types.any true in
166
	  Typer.report_unused_branches ();
167
	  Location.dump_loc ppf e.Typed.exp_loc;
168 169
	  if not !quiet then
	    Format.fprintf ppf "|- %a@\n@." print_norm t;
170
	  let v = Eval.eval Env.empty e in
171 172
	  if not !quiet then
	    Format.fprintf ppf "=> @[%a@]@\n@." print_value v
173
      | Ast.LetDecl (p,e) when is_abstraction e -> ()
174
      | Ast.LetDecl (p,e) ->
175
	  let decl = Typer.let_decl p e in
176
	  type_decl decl;
177
	  Typer.report_unused_branches ();
178 179 180 181 182 183 184
	  eval_decl decl
      | Ast.TypeDecl _ -> ()
      | Ast.Debug l -> debug ppf l
      | _ -> assert false
  in

  let do_fun_decls decls =
185
    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
186
    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
187
    Typer.report_unused_branches ();
188 189
    List.iter eval_decl decls
  in
190
  let rec phrases funs = function
191
    | { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e -> 
192 193 194 195 196 197 198 199
	phrases ((p,e)::funs) phs
    | ph :: phs ->
	do_fun_decls funs;
	phrase ph;
	phrases [] phs
    | _ ->
	do_fun_decls funs
  in
200
  try 
201 202 203 204
    let p = 
      try Parser.prog input
      with
	| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
205
	| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
206
    in
207
    let (type_decls,fun_decls) = 
208
      List.fold_left
209 210
	(fun ((typs,funs) as accu) ph -> match ph.descr with
	   | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
211
	   | Ast.LetDecl (p,e) when is_abstraction e -> 
212
	       (typs, (p,e)::funs)
213
	   | _ -> accu
214
	) ([],[]) p in
215
    Typer.register_global_types type_decls;
216
    phrases [] p;
217
    true
218
  with 
219
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
220
	raise e  (* To get ocamlrun stack trace *)
221
    | exn -> print_exn ppf_err exn; false
222
	
223