viewcvs.cgi/driver/cduce.ml

open Location
open Ident

let quiet = ref false

let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty

let rec is_abstraction = function
  | Ast.Abstraction _ -> true
  | Ast.LocatedExpr (_,e) -> is_abstraction e
  | _ -> false

let print_norm ppf d = 
  Location.protect ppf 
    (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))

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

let dump_env ppf =
  Format.fprintf ppf "Global types:";
  Typer.dump_global_types ppf;
  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"
         (Id.value x)
         print_norm t
         print_value v
    )
    !Eval.global_env
  

let rec print_exn ppf = function
  | Location (loc, exn) ->
      Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
      Format.fprintf ppf "%a" Location.html_hilight loc;
      print_exn ppf exn
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
        print_value v
  | Typer.WrongLabel (t,l) ->
      Format.fprintf ppf "Wrong record selection: the label %s@\n" 
        (LabelPool.value l);
      Format.fprintf ppf "applied to an expression of type:@\n%a@\n"
        print_norm t
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type:@\n%a@\n%s@\n" 
        print_norm t
        msg
  | Typer.ShouldHave2 (t1,msg,t2) ->
      Format.fprintf ppf "This expression should have type:@\n%a@\n%s %a@\n" 
        print_norm t1
        msg
        print_norm t2
  | Typer.Constraint (s,t,msg) ->
      Format.fprintf ppf "This expression should have type:@\n%a@\n" 
        print_norm t;
      Format.fprintf ppf "but its infered type is:@\n%a@\n" 
        print_norm s;
      Format.fprintf ppf "which is not a subtype, as shown by the value " ;
      Location.protect ppf
        (fun ppf ->
           Types.Sample.print ppf (Types.Sample.get (Types.diff s t)));
      Format.fprintf ppf "@\n%s@\n" msg
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type:@\n%a@\n"
        print_norm t;
      Format.fprintf ppf "Sample value:@\n%a@\n" 
        Types.Sample.print (Types.Sample.get t)
  | Typer.UnboundId x ->
      Format.fprintf ppf "Unbound identifier %s@\n" x
  | 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"
  | Parser.Error s | Stream.Error s -> 
      Format.fprintf ppf "Parsing error: %s@\n" s
  | Location.Generic s ->
      Format.fprintf ppf "%s@\n" s
  | exn ->
      raise exn
(*
      Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
*)

let debug ppf = function
  | `Subtype (t1,t2) ->
      Format.fprintf ppf "[DEBUG:subtype]@\n";
      let t1 = Types.descr (Typer.typ t1)
      and t2 = Types.descr (Typer.typ t2) in
      Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
        (Types.subtype t1 t2)
  | `Filter (t,p) -> 
      Format.fprintf ppf "[DEBUG:filter]@\n";
      let t = Typer.typ t
      and p = Typer.pat p in
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
                   Format.fprintf ppf " %s:%a@\n" (Id.value x)
                     print_norm (Types.descr t)) f
  | `Compile2 (t,pl) -> 
      Format.fprintf ppf "[DEBUG:compile2]@\n";
(*      let t = Types.descr (Typer.typ t) in
      let pl = List.map (fun p -> 
                           let p = Typer.pat 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 *)
      ()

  | `Accept p ->
      Format.fprintf ppf "[DEBUG:accept]@\n";
      let p = Typer.pat p in
      let t = Patterns.accept p in
      Format.fprintf ppf " %a@\n" Types.Print.print t
  | `Compile (t,pl) ->
      Format.fprintf ppf "[DEBUG:compile]@\n";
      let t = Typer.typ t
      and pl = List.map Typer.pat pl in
      Patterns.Compile.debug_compile ppf t pl
  | `Normal_record p -> assert false


let mk_builtin () =
  let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)]) 
             Builtin.types in
  List.iter Typer.register_global_types bi

let () = mk_builtin ()


let run ppf ppf_err input =
  let insert_type_bindings = 
    List.iter (fun (x,t) ->
                 typing_env := Typer.Env.add x t !typing_env;
                 if not !quiet then
                   Format.fprintf ppf "|- %s : %a@\n@." (Id.value x) print_norm t) 
  in
  
  let type_decl decl =
    insert_type_bindings (Typer.type_let_decl !typing_env decl);
    Typer.report_unused_branches ()
  in

  let eval_decl decl =
    let bindings = Eval.eval_let_decl Eval.Env.empty decl in
    List.iter 
      (fun (x,v) ->
         Eval.enter_global x v;
         if not !quiet then
           Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v
      ) bindings
  in

  let phrase ph = 
    match ph.descr with
      | Ast.EvalStatement e ->
          let (fv,e) = Typer.expr e in
          let t = Typer.type_check !typing_env e Types.any true in
          Typer.report_unused_branches ();
          Location.dump_loc ppf e.Typed.exp_loc;
          if not !quiet then
            Format.fprintf ppf "|- %a@\n@." print_norm t;
          let v = Eval.eval Eval.Env.empty e in
          if not !quiet then
            Format.fprintf ppf "=> @[%a@]@\n@." print_value v
      | Ast.LetDecl (p,e) when is_abstraction e -> ()
      | Ast.LetDecl (p,e) ->
          let decl = Typer.let_decl p e in
          type_decl decl;
          Typer.report_unused_branches ();
          eval_decl decl
      | Ast.TypeDecl _ -> ()
      | Ast.Debug l -> debug ppf l
      | _ -> assert false
  in

  let do_fun_decls decls =
    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
    Typer.report_unused_branches ();
    List.iter eval_decl decls
  in
  let rec phrases funs = function
    | { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e -> 
        phrases ((p,e)::funs) phs
    | ph :: phs ->
        do_fun_decls funs;
        phrase ph;
        phrases [] phs
    | _ ->
        do_fun_decls funs
  in
  try 
    let p = 
      try Parser.prog input
      with
        | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
        | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
    in
    let (type_decls,fun_decls) = 
      List.fold_left
        (fun ((typs,funs) as accu) ph -> match ph.descr with
           | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
           | Ast.LetDecl (p,e) when is_abstraction e -> 
               (typs, (p,e)::funs)
           | _ -> accu
        ) ([],[]) p in
    Typer.register_global_types type_decls;
    phrases [] p;
    true
  with 
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
        raise e  (* To get ocamlrun stack trace *)
    | exn -> print_exn ppf_err exn; false
        

1	open Location
2	open Ident
3
4	let quiet = ref false
5
6	let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
7
8	let rec is_abstraction = function
9	\| Ast.Abstraction _ -> true
10	\| Ast.LocatedExpr (_,e) -> is_abstraction e
11	\| _ -> false
12
13	let print_norm ppf d =
14	Location.protect ppf
15	(fun ppf -> Types.Print.print_descr ppf ((Types.normalize) d))
16
17	let print_value ppf v =
18	Location.protect ppf (fun ppf -> Value.print ppf v)
19
20	let dump_env ppf =
21	Format.fprintf ppf "Global types:";
22	Typer.dump_global_types ppf;
23	Format.fprintf ppf ".@\n";
24	Eval.Env.iter
25	(fun x v ->
26	let t = Typer.Env.find x !typing_env in
27	Format.fprintf ppf "@[\|- %s : %a@ => %a@]@\n"
28	(Id.value x)
29	print_norm t
30	print_value v
31	)
32	!Eval.global_env
33
34
35	let rec print_exn ppf = function
36	\| Location (loc, exn) ->
37	Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
38	Format.fprintf ppf "%a" Location.html_hilight loc;
39	print_exn ppf exn
40	\| Value.CDuceExn v ->
41	Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
42	print_value v
43	\| Typer.WrongLabel (t,l) ->
44	Format.fprintf ppf "Wrong record selection: the label %s@\n"
45	(LabelPool.value l);
46	Format.fprintf ppf "applied to an expression of type:@\n%a@\n"
47	print_norm t
48	\| Typer.ShouldHave (t,msg) ->
49	Format.fprintf ppf "This expression should have type:@\n%a@\n%s@\n"
50	print_norm t
51	msg
52	\| Typer.ShouldHave2 (t1,msg,t2) ->
53	Format.fprintf ppf "This expression should have type:@\n%a@\n%s %a@\n"
54	print_norm t1
55	msg
56	print_norm t2
57	\| Typer.Constraint (s,t,msg) ->
58	Format.fprintf ppf "This expression should have type:@\n%a@\n"
59	print_norm t;
60	Format.fprintf ppf "but its infered type is:@\n%a@\n"
61	print_norm s;
62	Format.fprintf ppf "which is not a subtype, as shown by the value " ;
63	Location.protect ppf
64	(fun ppf ->
65	Types.Sample.print ppf (Types.Sample.get (Types.diff s t)));
66	Format.fprintf ppf "@\n%s@\n" msg
67	\| Typer.NonExhaustive t ->
68	Format.fprintf ppf "This pattern matching is not exhaustive@\n";
69	Format.fprintf ppf "Residual type:@\n%a@\n"
70	print_norm t;
71	Format.fprintf ppf "Sample value:@\n%a@\n"
72	Types.Sample.print (Types.Sample.get t)
73	\| Typer.UnboundId x ->
74	Format.fprintf ppf "Unbound identifier %s@\n" x
75	\| Wlexer.Illegal_character c ->
76	Format.fprintf ppf "Illegal character (%s)@\n" (Char.escaped c)
77	\| Wlexer.Unterminated_comment ->
78	Format.fprintf ppf "Comment not terminated@\n"
79	\| Wlexer.Unterminated_string ->
80	Format.fprintf ppf "String literal not terminated@\n"
81	\| Wlexer.Unterminated_string_in_comment ->
82	Format.fprintf ppf "This comment contains an unterminated string literal@\n"
83	\| Parser.Error s \| Stream.Error s ->
84	Format.fprintf ppf "Parsing error: %s@\n" s
85	\| Location.Generic s ->
86	Format.fprintf ppf "%s@\n" s
87	\| exn ->
88	raise exn
89	(*
90	Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
91	*)
92
93	let debug ppf = function
94	\| `Subtype (t1,t2) ->
95	Format.fprintf ppf "[DEBUG:subtype]@\n";
96	let t1 = Types.descr (Typer.typ t1)
97	and t2 = Types.descr (Typer.typ t2) in
98	Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
99	(Types.subtype t1 t2)
100	\| `Filter (t,p) ->
101	Format.fprintf ppf "[DEBUG:filter]@\n";
102	let t = Typer.typ t
103	and p = Typer.pat p in
104	let f = Patterns.filter (Types.descr t) p in
105	List.iter (fun (x,t) ->
106	Format.fprintf ppf " %s:%a@\n" (Id.value x)
107	print_norm (Types.descr t)) f
108	\| `Compile2 (t,pl) ->
109	Format.fprintf ppf "[DEBUG:compile2]@\n";
110	(* let t = Types.descr (Typer.typ t) in
111	let pl = List.map (fun p ->
112	let p = Typer.pat p in
113	let a = Types.descr (Patterns.accept p) in
114	(Some p, Types.cap a t)) pl in
115	let d = Patterns.Compiler.make_dispatcher t pl in
116	Patterns.Compiler.print_disp ppf d *)
117	()
118
119	\| `Accept p ->
120	Format.fprintf ppf "[DEBUG:accept]@\n";
121	let p = Typer.pat p in
122	let t = Patterns.accept p in
123	Format.fprintf ppf " %a@\n" Types.Print.print t
124	\| `Compile (t,pl) ->
125	Format.fprintf ppf "[DEBUG:compile]@\n";
126	let t = Typer.typ t
127	and pl = List.map Typer.pat pl in
128	Patterns.Compile.debug_compile ppf t pl
129	\| `Normal_record p -> assert false
130
131
132
133	let mk_builtin () =
134	let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)])
135	Builtin.types in
136	List.iter Typer.register_global_types bi
137
138	let () = mk_builtin ()
139
140
141	let run ppf ppf_err input =
142	let insert_type_bindings =
143	List.iter (fun (x,t) ->
144	typing_env := Typer.Env.add x t !typing_env;
145	if not !quiet then
146	Format.fprintf ppf "\|- %s : %a@\n@." (Id.value x) print_norm t)
147	in
148
149	let type_decl decl =
150	insert_type_bindings (Typer.type_let_decl !typing_env decl);
151	Typer.report_unused_branches ()
152	in
153
154	let eval_decl decl =
155	let bindings = Eval.eval_let_decl Eval.Env.empty decl in
156	List.iter
157	(fun (x,v) ->
158	Eval.enter_global x v;
159	if not !quiet then
160	Format.fprintf ppf "=> %s : @[%a@]@\n@." (Id.value x) print_value v
161	) bindings
162	in
163
164	let phrase ph =
165	match ph.descr with
166	\| Ast.EvalStatement e ->
167	let (fv,e) = Typer.expr e in
168	let t = Typer.type_check !typing_env e Types.any true in
169	Typer.report_unused_branches ();
170	Location.dump_loc ppf e.Typed.exp_loc;
171	if not !quiet then
172	Format.fprintf ppf "\|- %a@\n@." print_norm t;
173	let v = Eval.eval Eval.Env.empty e in
174	if not !quiet then
175	Format.fprintf ppf "=> @[%a@]@\n@." print_value v
176	\| Ast.LetDecl (p,e) when is_abstraction e -> ()
177	\| Ast.LetDecl (p,e) ->
178	let decl = Typer.let_decl p e in
179	type_decl decl;
180	Typer.report_unused_branches ();
181	eval_decl decl
182	\| Ast.TypeDecl _ -> ()
183	\| Ast.Debug l -> debug ppf l
184	\| _ -> assert false
185	in
186
187	let do_fun_decls decls =
188	let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
189	insert_type_bindings (Typer.type_rec_funs !typing_env decls);
190	Typer.report_unused_branches ();
191	List.iter eval_decl decls
192	in
193	let rec phrases funs = function
194	\| { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e ->
195	phrases ((p,e)::funs) phs
196	\| ph :: phs ->
197	do_fun_decls funs;
198	phrase ph;
199	phrases [] phs
200	\| _ ->
201	do_fun_decls funs
202	in
203	try
204	let p =
205	try Parser.prog input
206	with
207	\| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
208	\| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
209	in
210	let (type_decls,fun_decls) =
211	List.fold_left
212	(fun ((typs,funs) as accu) ph -> match ph.descr with
213	\| Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
214	\| Ast.LetDecl (p,e) when is_abstraction e ->
215	(typs, (p,e)::funs)
216	\| _ -> accu
217	) ([],[]) p in
218	Typer.register_global_types type_decls;
219	phrases [] p;
220	true
221	with
222	\| (Failure _ \| Not_found \| Invalid_argument _) as e ->
223	raise e (* To get ocamlrun stack trace *)
224	\| exn -> print_exn ppf_err exn; false
225
226