viewcvs.cgi/driver/cduce.ml

open Location

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

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.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
  

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" 
        (Types.LabelPool.value l);
      Format.fprintf ppf "applied to an expression of type %a@\n"
        print_norm t
  | Typer.MultipleLabel l ->
      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
        (Types.LabelPool.value l);
  | Typer.ShouldHave (t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
        print_norm t
        msg
  | Typer.Constraint (s,t,msg) ->
      Format.fprintf ppf "This expression should have type %a@\n" 
        print_norm t;
      Format.fprintf ppf "but its infered type is: %a@\n" 
        print_norm s;
      Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
        Types.Sample.print (Types.Sample.get (Types.diff s t));
      Format.fprintf ppf "%s@\n" msg
  | Typer.NonExhaustive t ->
      Format.fprintf ppf "This pattern matching is not exhaustive@\n";
      Format.fprintf ppf "Residual type: %a@\n"
        print_norm t;
      Format.fprintf ppf "Sample value: %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
  | `Filter (t,p) -> 
      Format.fprintf ppf "[DEBUG:filter]@\n";
      let t = Typer.typ !glb_env t
      and p = Typer.pat !glb_env p in
      let f = Patterns.filter (Types.descr t) p in
      List.iter (fun (x,t) ->
                   Format.fprintf ppf " %s:%a@\n" x
                     print_norm (Types.descr t)) f
  | `Compile2 (t,pl) -> 
      Format.fprintf ppf "[DEBUG:compile2]@\n";
(*      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 *)
      ()

  | `Accept p ->
      Format.fprintf ppf "[DEBUG:accept]@\n";
      let p = Typer.pat !glb_env 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 !glb_env t
      and pl = List.map (Typer.pat !glb_env) pl in
      Patterns.Compile.debug_compile ppf t pl
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
      let t = Types.Record.get (Types.descr (Typer.typ !glb_env t)) in
      match Types.Record.first_label t with
            | `Fail -> Format.fprintf ppf "Empty@\n"
            | `Success -> Format.fprintf ppf "{ }@\n"
            | `NoField -> Format.fprintf ppf "{| |}@\n"
            | `SomeField -> Format.fprintf ppf "{ } \ {| |}@\n"
            | `Label l ->
                let (pr,ab) = Types.Record.normal' t l in
                Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
                List.iter (fun (d,n) ->
                             Format.fprintf ppf "%a => @[%a@];@\n"
                             Types.Print.print_descr d
                             Types.Print.print_descr (Types.Record.descr n)
                          ) pr;
                Format.fprintf ppf "@] Absent: @[%a@])@\n" 
                  Types.Print.print_descr 
                  (Types.Record.descr ab)
(*
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
      let t = Types.descr (Typer.typ !glb_env t) in
      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
*)


let mk_builtin () =
  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

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;
                 Format.fprintf ppf "|- %s : %a@\n@." x print_norm t) 
  in
  
  let type_decl decl =
    insert_type_bindings (Typer.type_let_decl !typing_env decl)
  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;
         Format.fprintf ppf "=> %s : @[%a@]@\n@." x print_value v
      ) bindings
  in

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