## error-message.pkg
#
# Possible future improvement in error reporting (thanks to Joe Wells for suggestion):
# A constraint system for a SML type error slicer
# Vincent Rahli, J. B. Wells, Fairouz Kamareddine
# http://www.macs.hw.ac.uk:8080/techreps/docs/files/HW-MACS-TR-0079.pdf
# http://www2.macs.hw.ac.uk/~rahli/cgi-bin/slicer/html/concepts.html
# Compiled by:
# src/lib/compiler/front/basics/basics.sublib### "I learn by making mistakes.
### I've learned a LOT."
###
### -- Eric Beggs
stipulate
package cp = control_print; # control_print is from src/lib/compiler/front/basics/print/control-print.pkg package lnd = line_number_db; # line_number_db is from src/lib/compiler/front/basics/source/line-number-db.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package sci = sourcecode_info; # sourcecode_info is from src/lib/compiler/front/basics/source/sourcecode-info.pkgherein
package error_message
: (weak) Error_Message # Error_Message is from src/lib/compiler/front/basics/errormsg/error-message.api {
exception COMPILE_ERROR; # Error reporting.
#
Severity = WARNING | ERROR;
Plaint_Sink
=
Severity
-> String
-> (pp::Prettyprinter -> Void)
-> Void
;
Error_Function
=
lnd::Source_Code_Region -> Plaint_Sink;
Errors = { error_fn: lnd::Source_Code_Region -> Plaint_Sink,
error_match: lnd::Source_Code_Region -> String,
saw_errors: Ref( Bool )
};
fun default_plaint_sink () # This matches Prettyprint_Consumer type in src/lib/prettyprint/big/src/old-prettyprinter.pkg = #
{ consumer => control_print::say,
flush => control_print::flush,
close => \\ () = ()
};
null_error_body
=
\\ (buf: pp::Prettyprinter) = ();
fun ppmsg # "ppmsg" == "prettyprint message"
( error_consumer,
location,
severity,
msg,
body
)
=
case (*basic_control::print_warnings, severity)
#
(FALSE, WARNING)
=>
();
_ =>
{
pp::with_standard_prettyprinter
#
error_consumer []
#
(\\ pp: pp::Prettyprinter
=
{ pp.box' 0 -1 {.
pp.newline();
pp.lit location;
# Print error label:
#
pp.lit
case severity
#
WARNING => " Warning: ";
ERROR => " Error: ";
esac;
pp.lit msg;
body pp;
};
pp.flush ();
}
);
};
esac;
fun record (ERROR, saw_errors)
=>
saw_errors := TRUE;
record (WARNING, _)
=>
();
end;
fun impossible msg
=
{ apply control_print::say ["Error: Compiler bug: ", msg, "\n"];
control_print::flush ();
raise exception COMPILE_ERROR;
};
# With the advent of source-map resynchronization (a.k.a
# [[( *#line...* )]]), a contiguous region as seen by the compiler can
# correspond to one or more contiguous regions in source code.
# We can imagine myriad ways of displaying such information, but we
# Confine ourselves to two:
# \begin { itemize }
# \item
# When there's just one source region,
# we have what we had in the old compiler,
# and we display it the same way:
# \begin { quote }
# {\tt \emph { name }:\emph { line }.\emph { col }} or\\
# {\tt \emph { name }:\emph { line1 }.\emph { col1 }-\emph { line2 }.\emph { col2 }}
# \end { quote }
# \item
# When there are two or more source regions, we use an ellipsis instead
# of a dash, and if not all regions are from the same file, we provide
# the file names of both endpoints (even if the endpoints are the same
# file).
# \end { itemize }
#
# <error-message.pkg>=
#
fun location_string
#
( { line_number_db, file_opened, ... }: sci::Sourcecode_Info)
#
(p1, p2)
=
{ fun shortpoint
( { line, column, ... }: lnd::Sourceloc,
l
)
=
int::to_string line ! "." ! int::to_string column ! l; # int is from src/lib/std/int.pkg fun showpoint (p as { file_name, ... }: lnd::Sourceloc, l)
=
pathnames::trim file_name ! ":" ! shortpoint (p, l); # pathnames is from src/lib/compiler/front/basics/source/pathnames.pkg fun allfiles (f, (src: lnd::Sourceloc, _) ! l)
=>
f == src.file_name and
allfiles (f, l);
allfiles (f, [])
=>
TRUE;
end;
fun lastpos [(_, hi)] => hi;
lastpos (h ! t) => lastpos t;
lastpos [] => impossible "lastpos botch in error_message::locationString";
end;
cat
case (lnd::fileregion line_number_db (p1, p2))
#
[(lo, hi)]
=>
if (p1+1 >= p2) showpoint (lo, []);
else showpoint (lo, "-" ! shortpoint (hi, []));
fi;
#
(lo, _) ! rest
=>
if (allfiles (lo.file_name, rest)) showpoint (lo, "..." ! shortpoint (lastpos rest, []));
else showpoint (lo, "..." ! showpoint (lastpos rest, []));
fi;
#
[] =>
[pathnames::trim file_opened, ":<nullRegion>"];
esac;
};
# "Emulating my predecessors, I've
# gone to some trouble to avoid
# list appends and the consequent
# allocations":
#
fun error (source as { saw_errors, error_consumer, ... }: sci::Sourcecode_Info)
( p1: Int,
p2: Int
)
(severity: Severity)
(msg: String)
(body: pp::Prettyprinter -> Void)
=
{ ppmsg
( error_consumer,
(location_string source (p1, p2)),
severity,
msg,
body
);
record (severity, saw_errors);
};
fun error_no_source
(cons, any_e)
locs
severity
msg
body
=
{ ppmsg (cons, locs, severity, msg, body);
record (severity, any_e);
};
fun error_no_file
#
(error_consumer, saw_errors)
#
((p1, p2): lnd::Source_Code_Region)
#
severity
msg
body
=
{ ppmsg
( error_consumer,
p2 > 0 ?? cat [int::to_string p1, "-", int::to_string p2]
:: "",
severity,
msg,
body
);
record (severity, saw_errors);
};
fun impossible_with_body
msg
body
=
{ pp::with_standard_prettyprinter
#
(default_plaint_sink ()) []
#
(\\ pp: pp::Prettyprinter
=
{ pp::lit pp "Error: Compiler bug: ";
pp::lit pp msg;
body pp;
pp::newline pp;
}
);
raise exception COMPILE_ERROR;
};
match_error_string
=
location_string;
fun errors source
=
{ error_fn => error source,
error_match => match_error_string source,
saw_errors => source.saw_errors
};
fun saw_errors { saw_errors, error_fn, error_match }
=
*saw_errors;
fun errors_no_file (consumer, saw_errors)
=
{ error_fn => error_no_file (consumer, saw_errors),
error_match => \\ _ = "MATCH",
saw_errors
};
}; # package error_message
end;