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