@ -26,11 +26,11 @@ type loc_trace = loc_trace_elem list
(* * Data associated to a specific error *)
(* * Data associated to a specific error *)
type err_data =
type err_data =
( int * int ) * int * Location . t * L . ml_loc option * loc_trace *
( int * int ) * int * Location . t * L . ml_loc option * loc_trace *
Prop. normal Prop . t option * Exceptions. err_class * Exceptions . exception_visibility
Exceptions. err_class * Exceptions . exception_visibility
let err_data_compare
let err_data_compare
( _ , _ , loc1 , _ , _ , _ , _ , _ )
( _ , _ , loc1 , _ , _ , _ , _ )
( _ , _ , loc2 , _ , _ , _ , _ , _ ) =
( _ , _ , loc2 , _ , _ , _ , _ ) =
Location . compare loc1 loc2
Location . compare loc1 loc2
module ErrDataSet = (* set err_data with no repeated loc *)
module ErrDataSet = (* set err_data with no repeated loc *)
@ -72,7 +72,6 @@ type iter_fun =
bool ->
bool ->
Localise . t -> Localise . error_desc -> string ->
Localise . t -> Localise . error_desc -> string ->
loc_trace ->
loc_trace ->
Prop . normal Prop . t option ->
Exceptions . err_class ->
Exceptions . err_class ->
Exceptions . exception_visibility ->
Exceptions . exception_visibility ->
unit
unit
@ -81,10 +80,10 @@ type iter_fun =
let iter ( f : iter_fun ) ( err_log : t ) =
let iter ( f : iter_fun ) ( err_log : t ) =
ErrLogHash . iter ( fun ( ekind , in_footprint , err_name , desc , severity ) set ->
ErrLogHash . iter ( fun ( ekind , in_footprint , err_name , desc , severity ) set ->
ErrDataSet . iter
ErrDataSet . iter
( fun ( node_id_key , _ , loc , ml_loc_opt , ltr , pre_opt, eclass, visibility ) ->
( fun ( node_id_key , _ , loc , ml_loc_opt , ltr , eclass, visibility ) ->
f
f
node_id_key loc ml_loc_opt ekind in_footprint err_name
node_id_key loc ml_loc_opt ekind in_footprint err_name
desc severity ltr pre_opt eclass visibility )
desc severity ltr eclass visibility )
set )
set )
err_log
err_log
@ -113,7 +112,7 @@ let pp_warnings fmt (errlog : t) =
let pp_html source path_to_root fmt ( errlog : t ) =
let pp_html source path_to_root fmt ( errlog : t ) =
let pp_eds fmt eds =
let pp_eds fmt eds =
let pp_nodeid_session_loc
let pp_nodeid_session_loc
fmt ( ( nodeid , _ ) , session , loc , _ , _ , _ , _ , _ ) =
fmt ( ( nodeid , _ ) , session , loc , _ , _ , _ , _ ) =
Io_infer . Html . pp_session_link source path_to_root fmt ( nodeid , session , loc . Location . line ) in
Io_infer . Html . pp_session_link source path_to_root fmt ( nodeid , session , loc . Location . line ) in
ErrDataSet . iter ( pp_nodeid_session_loc fmt ) eds in
ErrDataSet . iter ( pp_nodeid_session_loc fmt ) eds in
let f do_fp ek ( ekind , infp , err_name , desc , _ ) eds =
let f do_fp ek ( ekind , infp , err_name , desc , _ ) eds =
@ -168,7 +167,7 @@ let update errlog_old errlog_new =
( fun ( ekind , infp , s , desc , severity ) l ->
( fun ( ekind , infp , s , desc , severity ) l ->
ignore ( add_issue errlog_old ( ekind , infp , s , desc , severity ) l ) ) errlog_new
ignore ( add_issue errlog_old ( ekind , infp , s , desc , severity ) l ) ) errlog_new
let log_issue _ ekind err_log loc node_id_key session ltr pre_opt exn =
let log_issue _ ekind err_log loc node_id_key session ltr exn =
let err_name , desc , ml_loc_opt , visibility , severity , force_kind , eclass =
let err_name , desc , ml_loc_opt , visibility , severity , force_kind , eclass =
Exceptions . recognize_exception exn in
Exceptions . recognize_exception exn in
let ekind = match force_kind with
let ekind = match force_kind with
@ -191,7 +190,7 @@ let log_issue _ekind err_log loc node_id_key session ltr pre_opt exn =
add_issue err_log
add_issue err_log
( ekind , ! Config . footprint , err_name , desc , severity_to_str severity )
( ekind , ! Config . footprint , err_name , desc , severity_to_str severity )
( ErrDataSet . singleton
( ErrDataSet . singleton
( node_id_key , session , loc , ml_loc_opt , ltr , pre_opt, eclass, visibility ) ) in
( node_id_key , session , loc , ml_loc_opt , ltr , eclass, visibility ) ) in
let should_print_now =
let should_print_now =
match exn with
match exn with
| Exceptions . Internal_error _ -> true
| Exceptions . Internal_error _ -> true
@ -270,7 +269,7 @@ module Err_table = struct
ErrDataSet . iter ( fun loc -> add_err loc err_name ) eds in
ErrDataSet . iter ( fun loc -> add_err loc err_name ) eds in
ErrLogHash . iter f err_table ;
ErrLogHash . iter f err_table ;
let pp ekind ( nodeidkey , _ , loc , ml_loc_opt , _ , _ , _ , _ ) fmt err_names =
let pp ekind ( nodeidkey , _ , loc , ml_loc_opt , _ , _ , _ ) fmt err_names =
IList . iter ( fun ( err_name , desc ) ->
IList . iter ( fun ( err_name , desc ) ->
Exceptions . pp_err nodeidkey loc ekind err_name desc ml_loc_opt fmt () ) err_names in
Exceptions . pp_err nodeidkey loc ekind err_name desc ml_loc_opt fmt () ) err_names in
F . fprintf fmt " @.Detailed errors during footprint phase:@. " ;
F . fprintf fmt " @.Detailed errors during footprint phase:@. " ;