static struct value *make_exn_lns_error(struct info *info,
struct lns_error *err,
const char *text) {
struct value *v;
if (HAS_ERR(info))
return exn_error();
v = make_exn_value(ref(info), "%s", err->message);
if (err->lens != NULL) {
char *s = format_info(err->lens->info);
exn_printf_line(v, "Lens: %s", s);
free(s);
}
if (err->pos >= 0) {
char *pos = format_pos(text, err->pos);
size_t line, ofs;
calc_line_ofs(text, err->pos, &line, &ofs);
exn_printf_line(v,
"Error encountered at %d:%d (%d characters into string)",
(int) line, (int) ofs, err->pos);
if (pos != NULL)
exn_printf_line(v, "%s", pos);
free(pos);
} else {
exn_printf_line(v, "Error encountered at path %s", err->path);
}
return v;
}
static struct value *ambig_check(struct info *info, struct fa *fa1, struct fa *fa2,
const char *msg) {
char *upv, *pv, *v;
size_t upv_len;
fa_ambig_example(fa1, fa2, &upv, &upv_len, &pv, &v);
struct value *exn = NULL;
if (upv != NULL) {
char *e_u = escape(upv, pv - upv);
char *e_up = escape(upv, v - upv);
char *e_upv = escape(upv, -1);
char *e_pv = escape(pv, -1);
char *e_v = escape(v, -1);
exn = make_exn_value(ref(info), "%s", msg);
exn_printf_line(exn, " '%s' can be split into", e_upv);
exn_printf_line(exn, " '%s|=|%s'\n", e_u, e_pv);
exn_printf_line(exn, " and");
exn_printf_line(exn, " '%s|=|%s'\n", e_up, e_v);
free(e_u);
free(e_up);
free(e_upv);
free(e_pv);
free(e_v);
}
free(upv);
return exn;
}
/* Construct a finite automaton from REGEXP and return it in *FA.
*
* Return NULL if REGEXP is valid, if the regexp REGEXP has syntax errors,
* return an exception.
*/
static struct value *str_to_fa(struct info *info, const char *pattern,
struct fa **fa) {
int error;
struct value *exn = NULL;
size_t re_err_len;
char *re_str, *re_err;
error = fa_compile(pattern, strlen(pattern), fa);
if (error == REG_NOERROR)
return NULL;
re_str = escape(pattern, -1);
if (re_str == NULL) {
FIXME("Out of memory");
}
exn = make_exn_value(info, "Invalid regular expression /%s/", re_str);
re_err_len = regerror(error, NULL, NULL, 0);
if (ALLOC_N(re_err, re_err_len) < 0) {
FIXME("Out of memory");
}
regerror(error, NULL, re_err, re_err_len);
exn_printf_line(exn, "%s", re_err);
free(re_str);
free(re_err);
return exn;
}
/*
* Typechecking of lenses
*/
static struct value *disjoint_check(struct info *info, const char *msg,
struct regexp *r1, struct regexp *r2) {
struct fa *fa1 = NULL;
struct fa *fa2 = NULL;
struct fa *fa = NULL;
struct value *exn = NULL;
exn = regexp_to_fa(r1, &fa1);
if (exn != NULL)
goto done;
exn = regexp_to_fa(r2, &fa2);
if (exn != NULL)
goto done;
fa = fa_intersect(fa1, fa2);
if (! fa_is_basic(fa, FA_EMPTY)) {
size_t xmpl_len;
char *xmpl;
fa_example(fa, &xmpl, &xmpl_len);
exn = make_exn_value(ref(info),
"overlapping lenses in %s", msg);
exn_printf_line(exn, "Example matched by both: '%s'", xmpl);
free(xmpl);
}
done:
fa_free(fa);
fa_free(fa1);
fa_free(fa2);
return exn;
}
/* V_LENS -> V_STRING -> V_TREE */
static struct value *lens_get(struct info *info, struct value *l,
struct value *str) {
assert(l->tag == V_LENS);
assert(str->tag == V_STRING);
struct lns_error *err;
struct value *v;
const char *text = str->string->str;
struct tree *tree = lns_get(info, l->lens, text, &err);
if (err == NULL && ! HAS_ERR(info)) {
v = make_value(V_TREE, ref(info));
v->origin = make_tree_origin(tree);
} else {
struct tree *t = make_tree_origin(tree);
if (t == NULL)
free_tree(tree);
tree = t;
v = make_exn_lns_error(info, err, text);
if (tree != NULL) {
exn_printf_line(v, "Tree generated so far:");
exn_print_tree(v, tree);
free_tree(tree);
}
free_lns_error(err);
}
return v;
}
static void exn_print_tree(struct value *exn, struct tree *tree) {
struct memstream ms;
init_memstream(&ms);
dump_tree(ms.stream, tree);
close_memstream(&ms);
exn_printf_line(exn, "%s", ms.buf);
FREE(ms.buf);
}
static struct value *typecheck_union(struct info *info,
struct lens *l1, struct lens *l2) {
struct value *exn = NULL;
exn = disjoint_check(info, "union.get", l1->ctype, l2->ctype);
if (exn == NULL) {
exn = disjoint_check(info, "tree union.put", l1->atype, l2->atype);
}
if (exn != NULL) {
char *fi = format_info(l1->info);
exn_printf_line(exn, "First lens: %s", fi);
free(fi);
fi = format_info(l2->info);
exn_printf_line(exn, "Second lens: %s", fi);
free(fi);
}
return exn;
}
static struct value *typecheck_concat(struct info *info,
struct lens *l1, struct lens *l2) {
struct value *result = NULL;
result = ambig_concat_check(info, "ambiguous concatenation",
l1->ctype, l2->ctype);
if (result == NULL) {
result = ambig_concat_check(info, "ambiguous tree concatenation",
l1->atype, l2->atype);
}
if (result != NULL) {
char *fi = format_info(l1->info);
exn_printf_line(result, "First lens: %s", fi);
free(fi);
fi = format_info(l2->info);
exn_printf_line(result, "Second lens: %s", fi);
free(fi);
}
return result;
}
static struct value *typecheck_iter(struct info *info, struct lens *l) {
struct value *result = NULL;
result = ambig_iter_check(info, "ambiguous iteration", l->ctype);
if (result == NULL) {
result = ambig_iter_check(info, "ambiguous tree iteration", l->atype);
}
if (result != NULL) {
char *fi = format_info(l->info);
exn_printf_line(result, "Iterated lens: %s", fi);
free(fi);
}
return result;
}
static struct value *sys_read_file(struct info *info, struct value *n) {
assert(n->tag == V_STRING);
char *str = NULL;
str = xread_file(n->string->str);
if (str == NULL) {
char error_buf[1024];
const char *errmsg;
errmsg = xstrerror(errno, error_buf, sizeof(error_buf));
struct value *exn = make_exn_value(ref(info),
"reading file %s failed:", n->string->str);
exn_printf_line(exn, "%s", errmsg);
return exn;
}
struct value *v = make_value(V_STRING, ref(info));
v->string = make_string(str);
return v;
}
