|
|
@@ -68,19 +68,196 @@ let unify_error_msg ctx = function
|
|
|
cf.cf_name ^ " has no overload for " ^ s_type ctx t
|
|
|
| FinalInvariance ->
|
|
|
"Cannot unify final and non-final fields"
|
|
|
- | Invalid_function_argument i ->
|
|
|
+ | Invalid_function_argument(i,_) ->
|
|
|
Printf.sprintf "Cannot unify argument %i" i
|
|
|
| Invalid_return_type ->
|
|
|
"Cannot unify return types"
|
|
|
| Unify_custom msg ->
|
|
|
msg
|
|
|
|
|
|
+module BetterErrors = struct
|
|
|
+ type access_kind =
|
|
|
+ | Field of string
|
|
|
+ | FunctionArgument of int * int
|
|
|
+ | FunctionReturn
|
|
|
+ | TypeParameter of int
|
|
|
+ | Root
|
|
|
+
|
|
|
+ type access = {
|
|
|
+ acc_kind : access_kind;
|
|
|
+ mutable acc_expected : Type.t;
|
|
|
+ mutable acc_actual : Type.t;
|
|
|
+ mutable acc_messages : unify_error list;
|
|
|
+ mutable acc_next : access option;
|
|
|
+ }
|
|
|
+
|
|
|
+ let s_access_kind = function
|
|
|
+ | Field s -> "Field " ^ s
|
|
|
+ | FunctionArgument(i,l) -> Printf.sprintf "FunctionArgument(%i, %i)" i l
|
|
|
+ | FunctionReturn -> "FunctionReturn"
|
|
|
+ | TypeParameter i -> Printf.sprintf "TypeParameter %i" i
|
|
|
+ | Root -> "Root"
|
|
|
+
|
|
|
+ let get_access_chain ctx l =
|
|
|
+ let make_acc kind actual expected = {
|
|
|
+ acc_kind = kind;
|
|
|
+ acc_expected = expected;
|
|
|
+ acc_actual = actual;
|
|
|
+ acc_messages = [];
|
|
|
+ acc_next = None;
|
|
|
+ } in
|
|
|
+ let root_acc = make_acc Root t_dynamic t_dynamic in
|
|
|
+ let current_acc = ref root_acc in
|
|
|
+ let add_message msg =
|
|
|
+ !current_acc.acc_messages <- msg :: !current_acc.acc_messages
|
|
|
+ in
|
|
|
+ let add_access kind =
|
|
|
+ let acc = make_acc kind t_dynamic t_dynamic in
|
|
|
+ !current_acc.acc_next <- Some acc;
|
|
|
+ current_acc := acc;
|
|
|
+ in
|
|
|
+ List.iter (fun err -> match err with
|
|
|
+ | Cannot_unify(t1,t2) ->
|
|
|
+ !current_acc.acc_actual <- t1;
|
|
|
+ !current_acc.acc_expected <- t2;
|
|
|
+ add_message err
|
|
|
+ | Invalid_field_type s ->
|
|
|
+ add_access (Field s);
|
|
|
+ | Invalid_function_argument(i,l) ->
|
|
|
+ add_access (FunctionArgument(i,l));
|
|
|
+ | Invalid_return_type ->
|
|
|
+ add_access FunctionReturn;
|
|
|
+ | Invariant_parameter i ->
|
|
|
+ add_access (TypeParameter i);
|
|
|
+ | _ ->
|
|
|
+ add_message err
|
|
|
+ ) l;
|
|
|
+ root_acc
|
|
|
+
|
|
|
+ (* non-recursive s_type *)
|
|
|
+ let rec s_type ctx t =
|
|
|
+ match t with
|
|
|
+ | TMono r ->
|
|
|
+ (match !r with
|
|
|
+ | None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
|
|
|
+ | Some t -> s_type ctx t)
|
|
|
+ | TEnum (e,tl) ->
|
|
|
+ s_type_path e.e_path ^ s_type_params ctx tl
|
|
|
+ | TInst (c,tl) ->
|
|
|
+ (match c.cl_kind with
|
|
|
+ | KExpr e -> Ast.s_expr e
|
|
|
+ | _ -> s_type_path c.cl_path ^ s_type_params ctx tl)
|
|
|
+ | TType (t,tl) ->
|
|
|
+ s_type_path t.t_path ^ s_type_params ctx tl
|
|
|
+ | TAbstract (a,tl) ->
|
|
|
+ s_type_path a.a_path ^ s_type_params ctx tl
|
|
|
+ | TFun ([],_) ->
|
|
|
+ "Void -> ..."
|
|
|
+ | TFun (l,t) ->
|
|
|
+ let args = match l with
|
|
|
+ | [] -> "()"
|
|
|
+ | ["",b,t] -> ("...")
|
|
|
+ | _ ->
|
|
|
+ let args = String.concat ", " (List.map (fun (s,b,t) ->
|
|
|
+ (if b then "?" else "") ^ ("...")
|
|
|
+ ) l) in
|
|
|
+ "(" ^ args ^ ")"
|
|
|
+ in
|
|
|
+ Printf.sprintf "%s -> ..." args
|
|
|
+ | TAnon a ->
|
|
|
+ begin
|
|
|
+ match !(a.a_status) with
|
|
|
+ | Statics c -> Printf.sprintf "{ Statics %s }" (s_type_path c.cl_path)
|
|
|
+ | EnumStatics e -> Printf.sprintf "{ EnumStatics %s }" (s_type_path e.e_path)
|
|
|
+ | AbstractStatics a -> Printf.sprintf "{ AbstractStatics %s }" (s_type_path a.a_path)
|
|
|
+ | _ ->
|
|
|
+ let fl = PMap.fold (fun f acc -> ((if Meta.has Meta.Optional f.cf_meta then " ?" else " ") ^ f.cf_name) :: acc) a.a_fields [] in
|
|
|
+ "{" ^ (if not (is_closed a) then "+" else "") ^ String.concat "," fl ^ " }"
|
|
|
+ end
|
|
|
+ | TDynamic t2 ->
|
|
|
+ "Dynamic" ^ s_type_params ctx (if t == t2 then [] else [t2])
|
|
|
+ | TLazy f ->
|
|
|
+ s_type ctx (lazy_type f)
|
|
|
+
|
|
|
+ and s_type_params ctx = function
|
|
|
+ | [] -> ""
|
|
|
+ | l -> "<" ^ String.concat ", " (List.map (fun _ -> "...") l) ^ ">"
|
|
|
+
|
|
|
+ let better_error_message l =
|
|
|
+ let ctx = print_context() in
|
|
|
+ let rec loop acc l = match l with
|
|
|
+ | (Cannot_unify _) as err1 :: (Cannot_unify _) :: l ->
|
|
|
+ loop acc (err1 :: l)
|
|
|
+ | x :: l ->
|
|
|
+ loop (x :: acc) l
|
|
|
+ | [] ->
|
|
|
+ List.rev acc
|
|
|
+ in
|
|
|
+ let l = loop [] l in
|
|
|
+ let access = get_access_chain ctx l in
|
|
|
+ let message_buffer = Buffer.create 0 in
|
|
|
+ let rec fill s i acc k l =
|
|
|
+ if l = 0 then
|
|
|
+ List.rev acc
|
|
|
+ else begin
|
|
|
+ if k = i then fill s i (s :: acc) (k + 1) (l - 1)
|
|
|
+ else fill s i ("..." :: acc) (k + 1) (l - 1)
|
|
|
+ end
|
|
|
+ in
|
|
|
+ let rec loop access access_prev =
|
|
|
+ let loop () = match access.acc_next with
|
|
|
+ | Some access' -> loop access' access
|
|
|
+ | None ->
|
|
|
+ begin match access.acc_messages with
|
|
|
+ | err :: _ ->
|
|
|
+ let msg = unify_error_msg ctx err in
|
|
|
+ Buffer.add_string message_buffer msg;
|
|
|
+ | [] ->
|
|
|
+ ()
|
|
|
+ end;
|
|
|
+ s_type ctx access.acc_actual,s_type ctx access.acc_expected
|
|
|
+ in
|
|
|
+ begin match access.acc_kind with
|
|
|
+ | Field s ->
|
|
|
+ let s1,s2 = loop() in
|
|
|
+ Printf.sprintf "{ %s: %s }" s s1,Printf.sprintf "{ %s: %s }" s s2
|
|
|
+ | FunctionArgument(i,l) ->
|
|
|
+ let s1,s2 = loop() in
|
|
|
+ let sl1 = fill s1 i [] 1 l in
|
|
|
+ let sl2 = fill s2 i [] 1 l in
|
|
|
+ Printf.sprintf "(%s) -> ..." (String.concat ", " sl1),Printf.sprintf "(%s) -> ..." (String.concat ", " sl2)
|
|
|
+ | FunctionReturn ->
|
|
|
+ let s1,s2 = loop() in
|
|
|
+ Printf.sprintf "(...) -> %s" s1,Printf.sprintf "(...) -> %s" s2
|
|
|
+ | TypeParameter i ->
|
|
|
+ let rec get_params t = match t with
|
|
|
+ | TInst({cl_path = path},params) | TEnum({e_path = path},params) | TAbstract({a_path = path},params) | TType({t_path = path},params) ->
|
|
|
+ path,params
|
|
|
+ | _ ->
|
|
|
+ assert false
|
|
|
+ in
|
|
|
+ let s1,s2 = loop() in
|
|
|
+ let path1,params1 = get_params access_prev.acc_actual in
|
|
|
+ let path2,params2 = get_params access_prev.acc_expected in
|
|
|
+ let sl1 = fill s1 i [] 1 (List.length params1) in
|
|
|
+ let sl2 = fill s2 i [] 1 (List.length params2) in
|
|
|
+ Printf.sprintf "%s<%s>" (s_type_path path1) (String.concat ", " sl1),Printf.sprintf "%s<%s>" (s_type_path path2) (String.concat ", " sl2)
|
|
|
+ | Root ->
|
|
|
+ loop()
|
|
|
+ end;
|
|
|
+ in
|
|
|
+ match access.acc_next with
|
|
|
+ | None ->
|
|
|
+ String.concat "\n" (List.rev_map (unify_error_msg ctx) access.acc_messages)
|
|
|
+ | Some access_next ->
|
|
|
+ let slhs,srhs = loop access_next access in
|
|
|
+ Printf.sprintf "error: %s\n have: %s\n want: %s" (Buffer.contents message_buffer) slhs srhs
|
|
|
+end
|
|
|
+
|
|
|
let rec error_msg = function
|
|
|
| Module_not_found m -> "Type not found : " ^ s_type_path m
|
|
|
| Type_not_found (m,t) -> "Module " ^ s_type_path m ^ " does not define type " ^ t
|
|
|
- | Unify l ->
|
|
|
- let ctx = print_context() in
|
|
|
- String.concat "\n" (List.map (unify_error_msg ctx) l)
|
|
|
+ | Unify l -> BetterErrors.better_error_message l
|
|
|
| Unknown_ident s -> "Unknown identifier : " ^ s
|
|
|
| Custom s -> s
|
|
|
| Stack (m1,m2) -> error_msg m1 ^ "\n" ^ error_msg m2
|
Simon Krajewski