viewcvs.cgi/driver/cduce.ml

open Location

let print_norm ppf d = 
  Types.Print.print_descr ppf ((*Types.normalize*) d)

let rec print_exn ppf = function
  | Location (loc, exn) ->
      Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn exn
  | Value.CDuceExn v ->
      Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
        Value.print 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
  | 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 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" x
                     print_norm (Types.descr t)) f
  | `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
      let pl = Array.of_list 
                 (List.map (fun p -> Patterns.Compile.normal 
                              (Patterns.descr p)) pl) in
      Patterns.Compile.show ppf (Types.descr t) pl
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
      let t = Types.descr (Typer.typ t) in
      let count = ref 0 and seen = ref [] in
      match Types.Record.first_label t with
            | `Empty -> Format.fprintf ppf "Empty"
            | `Any -> Format.fprintf ppf "Any"
            | `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 n
                          ) pr;
                Format.fprintf ppf "@] Absent: @[%a@])@\n" 
                  Types.Print.print_descr 
                  (match ab with Some x -> x | None -> Types.empty)
(*
  | `Normal_record t ->
      Format.fprintf ppf "[DEBUG:normal_record]@\n";
      let t = Types.descr (Typer.typ 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 () =
  List.iter 
    (fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
    Builtin.types

let run ppf input =
  let typing_env = ref Typer.Env.empty in
  let eval_env = ref Eval.Env.empty in
  
  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 decl in
    List.iter 
      (fun (x,v) ->
         Eval.enter_global x v;
         Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print 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
          Format.fprintf ppf "|- %a@\n@." print_norm t;
          let v = Eval.eval !eval_env e in
          Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
      | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
      | Ast.LetDecl (p,e) ->
          let decl = Typer.let_decl 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 p e) decls in
    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
    List.iter eval_decl decls
  in
  try 
    mk_builtin ();
    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
    Typer.register_global_types type_decls;
    do_fun_decls fun_decls;
    List.iter phrase p
  with 
    | (Failure _ | Not_found | Invalid_argument _) as e -> 
        raise e  (* To get ocamlrun stack trace *)
    | exn -> print_exn ppf exn
        

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