Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[enhance] compiler, typer: Error message with name type wich have sam…

…e original names (adding original package)
  • Loading branch information...
commit 985d77a66ff7f0596695fe873b4280624d841178 1 parent 160db1a
@BourgerieQuentin BourgerieQuentin authored
View
3  libqmlcompil/typer_w.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -219,6 +219,7 @@ let type_of_expr ?options:_ ?annotmap ~bypass_typer ~gamma expr =
W_ReportErrors.get_annotmap_for_error_report () in
let err_ctxt =
QmlError.Context.annoted_expr annotmap_for_err_report expr in
+ W_PrintTypes.pp_simple_type_prepare_sequence [ty1; ty2];
QmlError.error err_ctxt
"@[Types@ @{<red>%a@}@ and@ @{<red>%a@}@ are@ not@ compatible@]%a"
W_PrintTypes.pp_simple_type_start_sequence ty1
View
33 libqmlcompil/typer_w/w_PrintTypes.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -24,6 +24,31 @@
(* depends *)
module Format = Base.Format
+let original_ident = Hashtbl.create 16
+
+let pp_simple_type_prepare_sequence tys =
+ List.iter
+ (fun ty ->
+ let rec aux ty =
+ match ty.W_Algebra.sty_desc with
+ | W_Algebra.SType_var _ -> ()
+ | W_Algebra.SType_arrow (args, bd) ->
+ List.iter aux args; aux bd
+ | W_Algebra.SType_named n ->
+ Hashtbl.add original_ident (Ident.original_name n.W_Algebra.nst_name) n.W_Algebra.nst_name;
+ | W_Algebra.SType_sum_of_records {W_Algebra.ct_value = (ct, _)} ->
+ List.iter
+ (function {W_Algebra.rt_value = (rt, _)} -> List.iter (fun (_, st) -> aux st) rt)
+ ct
+ | W_Algebra.SType_forall _tsh -> (* TODO *) ()
+ in aux ty
+ ) tys
+
+let pp_type_ident fmt ident =
+ let o = (Ident.original_name ident) in
+ match Hashtbl.find_all original_ident o with
+ | [] | [_] -> Format.fprintf fmt "%s" o
+ | _ -> Format.fprintf fmt "%s from package %s" o (Ident.get_package_name ident)
let type_variables_counter = ref 0
@@ -502,8 +527,7 @@ let rec __pp_simple_type prio ppf ty =
W_Algebra.nst_args = args ;
W_Algebra.nst_unwinded = _manifest } ->
(* We never print the real representation of a named type. *)
- Format.fprintf ppf "%s@,"
- (QmlAst.TypeIdent.to_printable_string name) ;
+ Format.fprintf ppf "%a@," pp_type_ident name;
(* Only if there are parameters to the type constructor, print them
separated by a comma and enclosed between parentheses. Since
arguments of the constructor are always enclosed by parens,
@@ -759,7 +783,7 @@ let __explain_simple_type_abbrev prio ppf abbreved_ty =
W_Algebra.nst_args = args ;
W_Algebra.nst_unwinded = _manifest } ->
(* We never print the real representation of a named type. *)
- Format.fprintf ppf "%s" (QmlAst.TypeIdent.to_printable_string name) ;
+ Format.fprintf ppf "%a" pp_type_ident name ;
(* Only if there are parameters to the type constructor, print them
separated by a comma and enclosed between parentheses. Since
arguments of the constructor are always enclosed by parens,
@@ -839,7 +863,6 @@ let pp_simple_type ppf ty =
col_vars_to_reprint_if_sequence := []
-
let (pp_simple_type_start_sequence, pp_simple_type_continue_sequence,
pp_simple_type_end_sequence, pp_nothing_end_sequence) =
let printed_tys = ref [] in
View
1  libqmlcompil/typer_w/w_PrintTypes.mli
@@ -22,6 +22,7 @@
val pp_simple_type: Format.formatter -> W_Algebra.simple_type -> unit
+val pp_simple_type_prepare_sequence: W_Algebra.simple_type list -> unit
val pp_simple_type_start_sequence:
Format.formatter -> W_Algebra.simple_type -> unit
val pp_simple_type_continue_sequence:
View
4 libqmlcompil/typer_w/w_ReportErrors.ml
@@ -357,6 +357,7 @@ let report_unification_conflict_with_context
| W_InferErrors.UCC_pattern_coerce (pat, pat_ty, coercing_ty) ->
let err_ctxt =
QmlError.Context.annoted_pat public_annotmap_with_locs pat in
+ W_PrintTypes.pp_simple_type_prepare_sequence [pat_ty; coercing_ty; err_ty1; err_ty2];
QmlError.error err_ctxt
("@[Pattern@ has@ type@ @{<red>%a@}@ but@ is@ coerced@ into@ " ^^
"@{<red>%a@}.@]%a%a@.")
@@ -368,6 +369,7 @@ let report_unification_conflict_with_context
| W_InferErrors.UCC_apply (expr, fun_pat_ty, tmp_fun_ty) ->
let err_ctxt =
QmlError.Context.annoted_expr public_annotmap_with_locs expr in
+ W_PrintTypes.pp_simple_type_prepare_sequence [fun_pat_ty; tmp_fun_ty; err_ty1; err_ty2];
QmlError.error err_ctxt
("@[Function@ was@ found@ of@ type@ @{<red>%a@}@ but@ " ^^
"application@ expects@ it@ to@ be@ of@ type@ @{<red>%a@}.@]%a%a@.")
@@ -380,6 +382,7 @@ let report_unification_conflict_with_context
(expr, previous_left_ty, current_left_ty) ->
let err_ctxt =
QmlError.Context.annoted_expr public_annotmap_with_locs expr in
+ W_PrintTypes.pp_simple_type_prepare_sequence [previous_left_ty; current_left_ty; err_ty1; err_ty2];
QmlError.error err_ctxt
("@[Matched@ expression@ or@ previous@ patterns@ have@ type@ " ^^
"@{<red>%a@}@ but@ new@ pattern@ is@ found@ of@ type@ " ^^
@@ -393,6 +396,7 @@ let report_unification_conflict_with_context
(expr, ty_right_parts, ty_branch) ->
let err_ctxt =
QmlError.Context.annoted_expr public_annotmap_with_locs expr in
+ W_PrintTypes.pp_simple_type_prepare_sequence [ty_right_parts; ty_branch; err_ty1; err_ty2];
QmlError.error err_ctxt
("@[Previous@ right-side@ parts@ of@ the@ pattern@ matching@ " ^^
"return@ type@ @{<red>%a@}@ but@ current@ one@ returns@ " ^^
Please sign in to comment.
Something went wrong with that request. Please try again.