src/lens.c

   1 /*
   2  * lens.c:
   3  *
   4  * Copyright (C) 2007-2015 David Lutterkort
   5  *
   6  * This library is free software; you can redistribute it and/or
   7  * modify it under the terms of the GNU Lesser General Public
   8  * License as published by the Free Software Foundation; either
   9  * version 2.1 of the License, or (at your option) any later version.
  10  *
  11  * This library is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public
  17  * License along with this library; if not, write to the Free Software
  18  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
  19  *
  20  * Author: David Lutterkort <dlutter@redhat.com>
  21  */
  22
  23 #include <config.h>
  24 #include <stddef.h>
  25
  26 #include "lens.h"
  27 #include "memory.h"
  28 #include "errcode.h"
  29 #include "internal.h"
  30
  31 /* This enum must be kept in sync with type_offs and ntypes */
  32 enum lens_type {
  33     CTYPE, ATYPE, KTYPE, VTYPE
  34 };
  35
  36 static const int const type_offs[] = {
  37     offsetof(struct lens, ctype),
  38     offsetof(struct lens, atype),
  39     offsetof(struct lens, ktype),
  40     offsetof(struct lens, vtype)
  41 };
  42 static const int ntypes = sizeof(type_offs)/sizeof(type_offs[0]);
  43
  44 static const char *lens_type_names[] =
  45     { "ctype", "atype", "ktype", "vtype" };
  46
  47 #define ltype(lns, t) *((struct regexp **) ((char *) lns + type_offs[t]))
  48
  49 static struct value * typecheck_union(struct info *,
  50                                       struct lens *l1, struct lens *l2);
  51 static struct value *typecheck_concat(struct info *,
  52                                       struct lens *l1, struct lens *l2);
  53 static struct value *typecheck_square(struct info *,
  54                                       struct lens *l1, struct lens *l2);
  55 static struct value *typecheck_iter(struct info *info, struct lens *l);
  56 static struct value *typecheck_maybe(struct info *info, struct lens *l);
  57
  58 /* Lens names for pretty printing */
  59 /* keep order in sync with enum type */
  60 static const char *const tags[] = {
  61     "del", "store", "value", "key", "label", "seq", "counter",
  62     "concat", "union",
  63     "subtree", "star", "maybe", "rec", "square"
  64 };
  65
  66 #define ltag(lens) (tags[lens->tag - L_DEL])
  67
  68 static const struct string digits_string = {
  69     .ref = REF_MAX, .str = (char *) "[0123456789]+"
  70 };
  71 static const struct string *const digits_pat = &digits_string;
  72
  73 char *format_lens(struct lens *l) {
  74     char *inf = format_info(l->info);
  75     char *result;
  76
  77     xasprintf(&result, "%s[%s]%s", tags[l->tag - L_DEL], inf,
  78               l->recursive ? "R" : "r");
  79     free(inf);
  80     return result;
  81 }
  82
  83 #define BUG_LENS_TAG(lns)  bug_lens_tag(lns, __FILE__, __LINE__)
  84
  85 static void bug_lens_tag(struct lens *lens, const char *file, int lineno) {
  86     char *s = format_lens(lens);
  87
  88     if (lens != NULL && lens->info != NULL && lens->info->error != NULL) {
  89         bug_on(lens->info->error, file, lineno, "Unexpected lens tag %s", s);
  90     } else {
  91         /* We are really screwed */
  92         assert(0);
  93     }
  94     free(s);
  95     return;
  96 }
  97
  98 /* Construct a finite automaton from REGEXP and return it in *FA.
  99  *
 100  * Return NULL if REGEXP is valid, if the regexp REGEXP has syntax errors,
 101  * return an exception.
 102  */
 103 static struct value *str_to_fa(struct info *info, const char *pattern,
 104                                struct fa **fa, int nocase) {
 105     int error;
 106     struct value *exn = NULL;
 107     size_t re_err_len;
 108     char *re_str = NULL, *re_err = NULL;
 109
 110     *fa = NULL;
 111     error = fa_compile(pattern, strlen(pattern), fa);
 112     if (error == REG_NOERROR) {
 113         if (nocase) {
 114             error = fa_nocase(*fa);
 115             ERR_NOMEM(error < 0, info);
 116         }
 117         return NULL;
 118     }
 119
 120     re_str = escape(pattern, -1, RX_ESCAPES);
 121     ERR_NOMEM(re_str == NULL, info);
 122
 123     exn = make_exn_value(info, "Invalid regular expression /%s/", re_str);
 124
 125     re_err_len = regerror(error, NULL, NULL, 0);
 126     error = ALLOC_N(re_err, re_err_len);
 127     ERR_NOMEM(error < 0, info);
 128
 129     regerror(error, NULL, re_err, re_err_len);
 130     exn_printf_line(exn, "%s", re_err);
 131
 132  done:
 133     free(re_str);
 134     free(re_err);
 135     return exn;
 136  error:
 137     fa_free(*fa);
 138     *fa = NULL;
 139     exn = info->error->exn;
 140     goto done;
 141 }
 142
 143 static struct value *regexp_to_fa(struct regexp *regexp, struct fa **fa) {
 144     return str_to_fa(regexp->info, regexp->pattern->str, fa, regexp->nocase);
 145 }
 146
 147 static struct lens *make_lens(enum lens_tag tag, struct info *info) {
 148     struct lens *lens;
 149     make_ref(lens);
 150     lens->tag = tag;
 151     lens->info = info;
 152
 153     return lens;
 154 }
 155
 156 static struct lens *make_lens_unop(enum lens_tag tag, struct info *info,
 157                                   struct lens *child) {
 158     struct lens *lens = make_lens(tag, info);
 159     lens->child = child;
 160     lens->value = child->value;
 161     lens->key = child->key;
 162     return lens;
 163 }
 164
 165 typedef struct regexp *regexp_combinator(struct info *, int, struct regexp **);
 166
 167 static struct lens *make_lens_binop(enum lens_tag tag, struct info *info,
 168                                     struct lens *l1, struct lens *l2,
 169                                     regexp_combinator *combinator) {
 170     struct lens *lens = make_lens(tag, info);
 171     int n1 = (l1->tag == tag) ? l1->nchildren : 1;
 172     struct regexp **types = NULL;
 173
 174     if (lens == NULL)
 175         goto error;
 176
 177     lens->nchildren = n1;
 178     lens->nchildren += (l2->tag == tag) ? l2->nchildren : 1;
 179
 180     lens->recursive = l1->recursive || l2->recursive;
 181     lens->rec_internal = l1->rec_internal || l2->rec_internal;
 182
 183     if (ALLOC_N(lens->children, lens->nchildren) < 0) {
 184         lens->nchildren = 0;
 185         goto error;
 186     }
 187
 188     if (l1->tag == tag) {
 189         for (int i=0; i < l1->nchildren; i++)
 190             lens->children[i] = ref(l1->children[i]);
 191         unref(l1, lens);
 192     } else {
 193         lens->children[0] = l1;
 194     }
 195
 196     if (l2->tag == tag) {
 197         for (int i=0; i < l2->nchildren; i++)
 198             lens->children[n1 + i] = ref(l2->children[i]);
 199         unref(l2, lens);
 200     } else {
 201         lens->children[n1] = l2;
 202     }
 203
 204     for (int i=0; i < lens->nchildren; i++) {
 205         lens->value = lens->value || lens->children[i]->value;
 206         lens->key = lens->key || lens->children[i]->key;
 207     }
 208
 209     if (ALLOC_N(types, lens->nchildren) < 0)
 210         goto error;
 211
 212     if (! lens->rec_internal) {
 213         /* Inside a recursive lens, we assign types with lns_check_rec
 214          * once we know the entire lens */
 215         for (int t=0; t < ntypes; t++) {
 216             if (lens->recursive && t == CTYPE)
 217                 continue;
 218             for (int i=0; i < lens->nchildren; i++)
 219                 types[i] = ltype(lens->children[i], t);
 220             ltype(lens, t) = (*combinator)(info, lens->nchildren, types);
 221         }
 222     }
 223     FREE(types);
 224
 225     for (int i=0; i < lens->nchildren; i++)
 226         ensure(tag != lens->children[i]->tag, lens->info);
 227
 228     return lens;
 229  error:
 230     unref(lens, lens);
 231     FREE(types);
 232     return NULL;
 233 }
 234
 235 static struct value *make_lens_value(struct lens *lens) {
 236     struct value *v;
 237     v = make_value(V_LENS, ref(lens->info));
 238     v->lens = lens;
 239     return v;
 240 }
 241
 242 struct value *lns_make_union(struct info *info,
 243                              struct lens *l1, struct lens *l2, int check) {
 244     struct lens *lens = NULL;
 245     int consumes_value = l1->consumes_value && l2->consumes_value;
 246     int recursive = l1->recursive || l2->recursive;
 247     int ctype_nullable = l1->ctype_nullable || l2->ctype_nullable;
 248
 249     if (check) {
 250         struct value *exn = typecheck_union(info, l1, l2);
 251         if (exn != NULL)
 252             return exn;
 253     }
 254
 255     lens = make_lens_binop(L_UNION, info, l1, l2, regexp_union_n);
 256     lens->consumes_value = consumes_value;
 257     if (! recursive)
 258         lens->ctype_nullable = ctype_nullable;
 259     return make_lens_value(lens);
 260 }
 261
 262 struct value *lns_make_concat(struct info *info,
 263                               struct lens *l1, struct lens *l2, int check) {
 264     struct lens *lens = NULL;
 265     int consumes_value = l1->consumes_value || l2->consumes_value;
 266     int recursive = l1->recursive || l2->recursive;
 267     int ctype_nullable = l1->ctype_nullable && l2->ctype_nullable;
 268
 269     if (check) {
 270         struct value *exn = typecheck_concat(info, l1, l2);
 271         if (exn != NULL)
 272             return exn;
 273     }
 274     if (l1->value && l2->value) {
 275         return make_exn_value(info, "Multiple stores in concat");
 276     }
 277     if (l1->key && l2->key) {
 278         return make_exn_value(info, "Multiple keys/labels in concat");
 279     }
 280
 281     lens = make_lens_binop(L_CONCAT, info, l1, l2, regexp_concat_n);
 282     lens->consumes_value = consumes_value;
 283     if (! recursive)
 284         lens->ctype_nullable = ctype_nullable;
 285     return make_lens_value(lens);
 286 }
 287
 288 static struct regexp *subtree_atype(struct info *info,
 289                                     struct regexp *ktype,
 290                                     struct regexp *vtype) {
 291     const char *kpat = (ktype == NULL) ? ENC_NULL : ktype->pattern->str;
 292     const char *vpat = (vtype == NULL) ? ENC_NULL : vtype->pattern->str;
 293     char *pat;
 294     struct regexp *result = NULL;
 295     char *ks = NULL, *vs = NULL;
 296     int nocase;
 297
 298     if (ktype != NULL && vtype != NULL && ktype->nocase != vtype->nocase) {
 299         ks = regexp_expand_nocase(ktype);
 300         vs = regexp_expand_nocase(vtype);
 301         ERR_NOMEM(ks == NULL || vs == NULL, info);
 302         if (asprintf(&pat, "(%s)%s(%s)%s", ks, ENC_EQ, vs, ENC_SLASH) < 0)
 303             ERR_NOMEM(true, info);
 304         nocase = 0;
 305     } else {
 306         if (asprintf(&pat, "(%s)%s(%s)%s", kpat, ENC_EQ, vpat, ENC_SLASH) < 0)
 307             ERR_NOMEM(pat == NULL, info);
 308
 309         nocase = 0;
 310         if (ktype != NULL)
 311             nocase = ktype->nocase;
 312         else if (vtype != NULL)
 313             nocase = vtype->nocase;
 314     }
 315     result = make_regexp(info, pat, nocase);
 316  error:
 317     free(ks);
 318     free(vs);
 319     return result;
 320 }
 321
 322 /*
 323  * A subtree lens l1 = [ l ]
 324  *
 325  * Types are assigned as follows:
 326  *
 327  * l1->ctype = l->ctype
 328  * l1->atype = encode(l->ktype, l->vtype)
 329  * l1->ktype = NULL
 330  * l1->vtype = NULL
 331  */
 332 struct value *lns_make_subtree(struct info *info, struct lens *l) {
 333     struct lens *lens;
 334
 335     lens = make_lens_unop(L_SUBTREE, info, l);
 336     lens->ctype = ref(l->ctype);
 337     if (! l->recursive)
 338         lens->atype = subtree_atype(info, l->ktype, l->vtype);
 339     lens->value = lens->key = 0;
 340     lens->recursive = l->recursive;
 341     lens->rec_internal = l->rec_internal;
 342     if (! l->recursive)
 343         lens->ctype_nullable = l->ctype_nullable;
 344     return make_lens_value(lens);
 345 }
 346
 347 struct value *lns_make_star(struct info *info, struct lens *l, int check) {
 348     struct lens *lens;
 349
 350     if (check) {
 351         struct value *exn = typecheck_iter(info, l);
 352         if (exn != NULL)
 353             return exn;
 354     }
 355     if (l->value) {
 356         return make_exn_value(info, "Multiple stores in iteration");
 357     }
 358     if (l->key) {
 359         return make_exn_value(info, "Multiple keys/labels in iteration");
 360     }
 361
 362     lens = make_lens_unop(L_STAR, info, l);
 363     for (int t = 0; t < ntypes; t++) {
 364         ltype(lens, t) = regexp_iter(info, ltype(l, t), 0, -1);
 365     }
 366     lens->recursive = l->recursive;
 367     lens->rec_internal = l->rec_internal;
 368     lens->ctype_nullable = 1;
 369     return make_lens_value(lens);
 370 }
 371
 372 struct value *lns_make_plus(struct info *info, struct lens *l, int check) {
 373     struct value *star, *conc;
 374
 375     star = lns_make_star(info, l, check);
 376     if (EXN(star))
 377         return star;
 378
 379     conc = lns_make_concat(ref(info), ref(l), ref(star->lens), check);
 380     unref(star, value);
 381     return conc;
 382 }
 383
 384 struct value *lns_make_maybe(struct info *info, struct lens *l, int check) {
 385     struct lens *lens;
 386
 387     if (check) {
 388         struct value *exn = typecheck_maybe(info, l);
 389         if (exn != NULL)
 390             return exn;
 391     }
 392     lens = make_lens_unop(L_MAYBE, info, l);
 393     for (int t=0; t < ntypes; t++)
 394         ltype(lens, t) = regexp_maybe(info, ltype(l, t));
 395     lens->value = l->value;
 396     lens->key = l->key;
 397     lens->recursive = l->recursive;
 398     lens->rec_internal = l->rec_internal;
 399     lens->ctype_nullable = 1;
 400     return make_lens_value(lens);
 401 }
 402
 403 /* The ctype of SQR is a regular approximation of the true ctype of SQR
 404  * at this point. In some situations, for example in processing quoted
 405  * strings this leads to false typecheck errors; to lower the chances
 406  * of these, we try to construct the precise ctype of SQR if the
 407  * language of L1 is finite (and has a small number of words)
 408  */
 409 static void square_precise_type(struct info *info,
 410                                 struct regexp **sqr,
 411                                 struct regexp *left,
 412                                 struct regexp *body) {
 413
 414     char **words = NULL;
 415     int nwords = 0, r;
 416     struct fa *fa = NULL;
 417     struct value *exn = NULL;
 418     struct regexp **u = NULL, *c[3], *w = NULL;
 419
 420     exn = str_to_fa(info, left->pattern->str, &fa, left->nocase);
 421     if (exn != NULL)
 422         goto error;
 423
 424     nwords = fa_enumerate(fa, 10, &words); /* The limit of 10 is arbitrary */
 425     if (nwords < 0)
 426         goto error;
 427
 428     r = ALLOC_N(u, nwords);
 429     ERR_NOMEM(r < 0, info);
 430
 431     c[1] = body;
 432     for (int i=0; i < nwords; i++) {
 433         w = make_regexp_literal(left->info, words[i]);
 434         ERR_NOMEM(w == NULL, info);
 435         w->nocase = left->nocase;
 436
 437         c[0] = c[2] = w;
 438         u[i] = regexp_concat_n(info, 3, c);
 439
 440         unref(w, regexp);
 441         ERR_NOMEM(u[i] == NULL, info);
 442     }
 443     w = regexp_union_n(info, nwords, u);
 444     if (w != NULL) {
 445         unref(*sqr, regexp);
 446         *sqr = w;
 447         w = NULL;
 448     }
 449
 450  error:
 451     unref(w, regexp);
 452     for (int i=0; i < nwords; i++) {
 453         free(words[i]);
 454         if (u != NULL)
 455             unref(u[i], regexp);
 456     }
 457     free(words);
 458     free(u);
 459     fa_free(fa);
 460     unref(exn, value);
 461 }
 462
 463 /* Build a square lens as
 464  *    left . body . right
 465  * where left and right accepts the same language and
 466  * captured strings must match. The inability to express this with other
 467  * lenses makes the square primitive necessary.
 468  */
 469 struct value * lns_make_square(struct info *info, struct lens *l1,
 470                                struct lens *l2, struct lens *l3, int check) {
 471     struct value *cnt1 = NULL, *cnt2 = NULL, *res = NULL;
 472     struct lens *sqr = NULL;
 473
 474     /* supported types: L_KEY . body . L_DEL or L_DEL . body . L_DEL */
 475     if (l3->tag != L_DEL || (l1->tag != L_DEL && l1->tag != L_KEY))
 476         return make_exn_value(info, "Supported types: (key lns del) or (del lns del)");
 477
 478     res = typecheck_square(info, l1, l3);
 479     if (res != NULL)
 480         goto error;
 481
 482     res = lns_make_concat(ref(info), ref(l1), ref(l2), check);
 483     if (EXN(res))
 484         goto error;
 485     cnt1 = res;
 486     res = lns_make_concat(ref(info), ref(cnt1->lens), ref(l3), check);
 487     if (EXN(res))
 488         goto error;
 489     cnt2 = res;
 490
 491     sqr = make_lens_unop(L_SQUARE, ref(info), ref(cnt2->lens));
 492     ERR_NOMEM(sqr == NULL, info);
 493
 494     for (int t=0; t < ntypes; t++)
 495         ltype(sqr, t) = ref(ltype(cnt2->lens, t));
 496
 497     square_precise_type(info, &(sqr->ctype), l1->ctype, l2->ctype);
 498
 499     sqr->recursive = cnt2->lens->recursive;
 500     sqr->rec_internal = cnt2->lens->rec_internal;
 501     sqr->consumes_value = cnt2->lens->consumes_value;
 502
 503     res = make_lens_value(sqr);
 504     ERR_NOMEM(res == NULL, info);
 505     sqr = NULL;
 506
 507  error:
 508     unref(info, info);
 509     unref(l1, lens);
 510     unref(l2, lens);
 511     unref(l3, lens);
 512     unref(cnt1, value);
 513     unref(cnt2, value);
 514     unref(sqr, lens);
 515     return res;
 516 }
 517
 518 /*
 519  * Lens primitives
 520  */
 521
 522 static struct regexp *make_regexp_from_string(struct info *info,
 523                                               struct string *string) {
 524     struct regexp *r;
 525     make_ref(r);
 526     if (r != NULL) {
 527         r->info = ref(info);
 528         r->pattern = ref(string);
 529         r->nocase = 0;
 530     }
 531     return r;
 532 }
 533
 534 static struct regexp *restrict_regexp(struct regexp *r) {
 535     char *nre = NULL;
 536     struct regexp *result = NULL;
 537     size_t nre_len;
 538     int ret;
 539
 540     ret = fa_restrict_alphabet(r->pattern->str, strlen(r->pattern->str),
 541                                &nre, &nre_len,
 542                                RESERVED_FROM, RESERVED_TO);
 543     ERR_NOMEM(ret == REG_ESPACE || ret < 0, r->info);
 544     BUG_ON(ret != 0, r->info, NULL);
 545     ensure(nre_len == strlen(nre), r->info);
 546
 547     ret = regexp_c_locale(&nre, &nre_len);
 548     ERR_NOMEM(ret < 0, r->info);
 549
 550     result = make_regexp(r->info, nre, r->nocase);
 551     nre = NULL;
 552     BUG_ON(regexp_compile(result) != 0, r->info,
 553            "Could not compile restricted regexp");
 554  done:
 555     free(nre);
 556     return result;
 557  error:
 558     unref(result, regexp);
 559     goto done;
 560 }
 561
 562 struct value *lns_make_prim(enum lens_tag tag, struct info *info,
 563                             struct regexp *regexp, struct string *string) {
 564     struct lens *lens = NULL;
 565     struct value *exn = NULL;
 566     struct fa *fa_slash = NULL;
 567     struct fa *fa_key = NULL;
 568     struct fa *fa_isect = NULL;
 569
 570     /* Typecheck */
 571     if (tag == L_KEY) {
 572         exn = str_to_fa(info, "(.|\n)*/(.|\n)*", &fa_slash, regexp->nocase);
 573         if (exn != NULL)
 574             goto error;
 575
 576         exn = regexp_to_fa(regexp, &fa_key);
 577         if (exn != NULL)
 578             goto error;
 579
 580         fa_isect = fa_intersect(fa_slash, fa_key);
 581         if (! fa_is_basic(fa_isect, FA_EMPTY)) {
 582             exn = make_exn_value(info,
 583                                  "The key regexp /%s/ matches a '/'",
 584                                  regexp->pattern->str);
 585             goto error;
 586         }
 587         fa_free(fa_isect);
 588         fa_free(fa_key);
 589         fa_free(fa_slash);
 590         fa_isect = fa_key = fa_slash = NULL;
 591     } else if (tag == L_LABEL) {
 592         if (strchr(string->str, SEP) != NULL) {
 593             exn = make_exn_value(info,
 594                                  "The label string \"%s\" contains a '/'",
 595                                  string->str);
 596             goto error;
 597         }
 598     } else if (tag == L_DEL && string != NULL) {
 599         int cnt;
 600         const char *dflt = string->str;
 601         cnt = regexp_match(regexp, dflt, strlen(dflt), 0, NULL);
 602         if (cnt != strlen(dflt)) {
 603             char *s = escape(dflt, -1, RX_ESCAPES);
 604             char *r = regexp_escape(regexp);
 605             exn = make_exn_value(info,
 606                    "del: the default value '%s' does not match /%s/",
 607                    s, r);
 608             FREE(s);
 609             FREE(r);
 610             goto error;
 611         }
 612     }
 613
 614     /* Build the actual lens */
 615     lens = make_lens(tag, info);
 616     lens->regexp = regexp;
 617     lens->string = string;
 618     lens->key = (tag == L_KEY || tag == L_LABEL || tag == L_SEQ);
 619     lens->value = (tag == L_STORE || tag == L_VALUE);
 620     lens->consumes_value = (tag == L_STORE || tag == L_VALUE);
 621     lens->atype = regexp_make_empty(info);
 622     /* Set the ctype */
 623     if (tag == L_DEL || tag == L_STORE || tag == L_KEY) {
 624         lens->ctype = ref(regexp);
 625         lens->ctype_nullable = regexp_matches_empty(lens->ctype);
 626     } else if (tag == L_LABEL || tag == L_VALUE
 627                || tag == L_SEQ || tag == L_COUNTER) {
 628         lens->ctype = regexp_make_empty(info);
 629         lens->ctype_nullable = 1;
 630     } else {
 631         BUG_LENS_TAG(lens);
 632         goto error;
 633     }
 634
 635
 636     /* Set the ktype */
 637     if (tag == L_SEQ) {
 638         lens->ktype =
 639             make_regexp_from_string(info, (struct string *) digits_pat);
 640         if (lens->ktype == NULL)
 641             goto error;
 642     } else if (tag == L_KEY) {
 643         lens->ktype = restrict_regexp(lens->regexp);
 644     } else if (tag == L_LABEL) {
 645         lens->ktype = make_regexp_literal(info, lens->string->str);
 646         if (lens->ktype == NULL)
 647             goto error;
 648     }
 649
 650     /* Set the vtype */
 651     if (tag == L_STORE) {
 652         lens->vtype = restrict_regexp(lens->regexp);
 653     } else if (tag == L_VALUE) {
 654         lens->vtype = make_regexp_literal(info, lens->string->str);
 655     }
 656
 657     return make_lens_value(lens);
 658  error:
 659     fa_free(fa_isect);
 660     fa_free(fa_key);
 661     fa_free(fa_slash);
 662     return exn;
 663 }
 664
 665 /*
 666  * Typechecking of lenses
 667  */
 668 static struct value *disjoint_check(struct info *info, bool is_get,
 669                                     struct regexp *r1, struct regexp *r2) {
 670     struct fa *fa1 = NULL;
 671     struct fa *fa2 = NULL;
 672     struct fa *fa = NULL;
 673     struct value *exn = NULL;
 674     const char *const msg = is_get ? "union.get" : "tree union.put";
 675
 676     if (r1 == NULL || r2 == NULL)
 677         return NULL;
 678
 679     exn = regexp_to_fa(r1, &fa1);
 680     if (exn != NULL)
 681         goto done;
 682
 683     exn = regexp_to_fa(r2, &fa2);
 684     if (exn != NULL)
 685         goto done;
 686
 687     fa = fa_intersect(fa1, fa2);
 688     if (! fa_is_basic(fa, FA_EMPTY)) {
 689         size_t xmpl_len;
 690         char *xmpl;
 691         fa_example(fa, &xmpl, &xmpl_len);
 692         if (! is_get) {
 693             char *fmt = enc_format(xmpl, xmpl_len);
 694             if (fmt != NULL) {
 695                 FREE(xmpl);
 696                 xmpl = fmt;
 697             }
 698         }
 699         exn = make_exn_value(ref(info),
 700                              "overlapping lenses in %s", msg);
 701
 702         if (is_get)
 703             exn_printf_line(exn, "Example matched by both: '%s'", xmpl);
 704         else
 705             exn_printf_line(exn, "Example matched by both: %s", xmpl);
 706         free(xmpl);
 707     }
 708
 709  done:
 710     fa_free(fa);
 711     fa_free(fa1);
 712     fa_free(fa2);
 713
 714     return exn;
 715 }
 716
 717 static struct value *typecheck_union(struct info *info,
 718                                      struct lens *l1, struct lens *l2) {
 719     struct value *exn = NULL;
 720
 721     exn = disjoint_check(info, true, l1->ctype, l2->ctype);
 722     if (exn == NULL) {
 723         exn = disjoint_check(info, false, l1->atype, l2->atype);
 724     }
 725     if (exn != NULL) {
 726         char *fi = format_info(l1->info);
 727         exn_printf_line(exn, "First lens: %s", fi);
 728         free(fi);
 729
 730         fi = format_info(l2->info);
 731         exn_printf_line(exn, "Second lens: %s", fi);
 732         free(fi);
 733     }
 734     return exn;
 735 }
 736
 737 static struct value *
 738 ambig_check(struct info *info, struct fa *fa1, struct fa *fa2,
 739             enum lens_type typ,  struct lens *l1, struct lens *l2,
 740             const char *msg, bool iterated) {
 741     char *upv, *pv, *v;
 742     size_t upv_len;
 743     struct value *exn = NULL;
 744     int r;
 745
 746     r = fa_ambig_example(fa1, fa2, &upv, &upv_len, &pv, &v);
 747     if (r < 0) {
 748         exn = make_exn_value(ref(info), "not enough memory");
 749         if (exn != NULL) {
 750             return exn;
 751         } else {
 752             ERR_REPORT(info, AUG_ENOMEM, NULL);
 753             return info->error->exn;
 754         }
 755     }
 756
 757     if (upv != NULL) {
 758         char *e_u, *e_up, *e_upv, *e_pv, *e_v;
 759         char *s1, *s2;
 760
 761         if (typ == ATYPE) {
 762             e_u = enc_format(upv, pv - upv);
 763             e_up = enc_format(upv, v - upv);
 764             e_upv = enc_format(upv, upv_len);
 765             e_pv = enc_format(pv, strlen(pv));
 766             e_v = enc_format(v, strlen(v));
 767             lns_format_atype(l1, &s1);
 768             lns_format_atype(l2, &s2);
 769         } else {
 770             e_u = escape(upv, pv - upv, RX_ESCAPES);
 771             e_up = escape(upv, v - upv, RX_ESCAPES);
 772             e_upv = escape(upv, -1, RX_ESCAPES);
 773             e_pv = escape(pv, -1, RX_ESCAPES);
 774             e_v = escape(v, -1, RX_ESCAPES);
 775             s1 = regexp_escape(ltype(l1, typ));
 776             s2 = regexp_escape(ltype(l2, typ));
 777         }
 778         exn = make_exn_value(ref(info), "%s", msg);
 779         if (iterated) {
 780             exn_printf_line(exn, "  Iterated regexp: /%s/", s1);
 781         } else {
 782             exn_printf_line(exn, "  First regexp: /%s/", s1);
 783             exn_printf_line(exn, "  Second regexp: /%s/", s2);
 784         }
 785         exn_printf_line(exn, "  '%s' can be split into", e_upv);
 786         exn_printf_line(exn, "  '%s|=|%s'\n", e_u, e_pv);
 787         exn_printf_line(exn, " and");
 788         exn_printf_line(exn, "  '%s|=|%s'\n", e_up, e_v);
 789         free(e_u);
 790         free(e_up);
 791         free(e_upv);
 792         free(e_pv);
 793         free(e_v);
 794         free(s1);
 795         free(s2);
 796     }
 797     free(upv);
 798     return exn;
 799 }
 800
 801 static struct value *
 802 ambig_concat_check(struct info *info, const char *msg,
 803                    enum lens_type typ, struct lens *l1, struct lens *l2) {
 804     struct fa *fa1 = NULL;
 805     struct fa *fa2 = NULL;
 806     struct value *result = NULL;
 807     struct regexp *r1 = ltype(l1, typ);
 808     struct regexp *r2 = ltype(l2, typ);
 809
 810     if (r1 == NULL || r2 == NULL)
 811         return NULL;
 812
 813     result = regexp_to_fa(r1, &fa1);
 814     if (result != NULL)
 815         goto done;
 816
 817     result = regexp_to_fa(r2, &fa2);
 818     if (result != NULL)
 819         goto done;
 820
 821     result = ambig_check(info, fa1, fa2, typ, l1, l2, msg, false);
 822  done:
 823     fa_free(fa1);
 824     fa_free(fa2);
 825     return result;
 826 }
 827
 828 static struct value *typecheck_concat(struct info *info,
 829                                       struct lens *l1, struct lens *l2) {
 830     struct value *result = NULL;
 831
 832     result = ambig_concat_check(info, "ambiguous concatenation",
 833                                 CTYPE, l1, l2);
 834     if (result == NULL) {
 835         result = ambig_concat_check(info, "ambiguous tree concatenation",
 836                                     ATYPE, l1, l2);
 837     }
 838     if (result != NULL) {
 839         char *fi = format_info(l1->info);
 840         exn_printf_line(result, "First lens: %s", fi);
 841         free(fi);
 842         fi = format_info(l2->info);
 843         exn_printf_line(result, "Second lens: %s", fi);
 844         free(fi);
 845     }
 846     return result;
 847 }
 848
 849 static struct value *make_exn_square(struct info *info, struct lens *l1,
 850                                      struct lens *l2, const char *msg) {
 851
 852     char *fi;
 853     struct value *exn = make_exn_value(ref(info), "%s",
 854             "Inconsistency in lens square");
 855     exn_printf_line(exn, "%s", msg);
 856     fi = format_info(l1->info);
 857     exn_printf_line(exn, "Left lens: %s", fi);
 858     free(fi);
 859     fi = format_info(l2->info);
 860     exn_printf_line(exn, "Right lens: %s", fi);
 861     free(fi);
 862     return exn;
 863 }
 864
 865 static struct value *typecheck_square(struct info *info, struct lens *l1,
 866                                       struct lens *l2) {
 867     int r;
 868     struct value *exn = NULL;
 869     struct fa *fa1 = NULL, *fa2 = NULL;
 870     struct regexp *r1 = ltype(l1, CTYPE);
 871     struct regexp *r2 = ltype(l2, CTYPE);
 872
 873     if (r1 == NULL || r2 == NULL)
 874         return NULL;
 875
 876     exn = regexp_to_fa(r1, &fa1);
 877     if (exn != NULL)
 878         goto done;
 879
 880     exn = regexp_to_fa(r2, &fa2);
 881     if (exn != NULL)
 882         goto done;
 883
 884     r = fa_equals(fa1, fa2);
 885
 886     if (r < 0) {
 887         exn = make_exn_value(ref(info), "not enough memory");
 888         if (exn != NULL) {
 889             return exn;
 890         } else {
 891             ERR_REPORT(info, AUG_ENOMEM, NULL);
 892             return info->error->exn;;
 893         }
 894     }
 895
 896     if (r == 0) {
 897         exn = make_exn_square(info, l1, l2,
 898                 "Left and right lenses must accept the same language");
 899         goto done;
 900     }
 901
 902     /* check del create consistency */
 903     if (l1->tag == L_DEL && l2->tag == L_DEL) {
 904         if (!STREQ(l1->string->str, l2->string->str)) {
 905             exn = make_exn_square(info, l1, l2,
 906                     "Left and right lenses must have the same default value");
 907             goto done;
 908         }
 909     }
 910
 911  done:
 912     fa_free(fa1);
 913     fa_free(fa2);
 914     return exn;
 915 }
 916
 917 static struct value *
 918 ambig_iter_check(struct info *info, const char *msg,
 919                  enum lens_type typ, struct lens *l) {
 920     struct fa *fas = NULL, *fa = NULL;
 921     struct value *result = NULL;
 922     struct regexp *r = ltype(l, typ);
 923
 924     if (r == NULL)
 925         return NULL;
 926
 927     result = regexp_to_fa(r, &fa);
 928     if (result != NULL)
 929         goto done;
 930
 931     fas = fa_iter(fa, 0, -1);
 932
 933     result = ambig_check(info, fa, fas, typ, l, l, msg, true);
 934
 935  done:
 936     fa_free(fa);
 937     fa_free(fas);
 938     return result;
 939 }
 940
 941 static struct value *typecheck_iter(struct info *info, struct lens *l) {
 942     struct value *result = NULL;
 943
 944     result = ambig_iter_check(info, "ambiguous iteration", CTYPE, l);
 945     if (result == NULL) {
 946         result = ambig_iter_check(info, "ambiguous tree iteration", ATYPE, l);
 947     }
 948     if (result != NULL) {
 949         char *fi = format_info(l->info);
 950         exn_printf_line(result, "Iterated lens: %s", fi);
 951         free(fi);
 952     }
 953     return result;
 954 }
 955
 956 static struct value *typecheck_maybe(struct info *info, struct lens *l) {
 957     /* Check (r)? as (<e>|r) where <e> is the empty language */
 958     struct value *exn = NULL;
 959
 960     if (l->ctype != NULL && regexp_matches_empty(l->ctype)) {
 961         exn = make_exn_value(ref(info),
 962                 "illegal optional expression: /%s/ matches the empty word",
 963                 l->ctype->pattern->str);
 964     }
 965
 966     /* Typecheck the put direction; the check passes if
 967        (1) the atype does not match the empty string, because we can tell
 968            from looking at tree nodes whether L should be applied or not
 969        (2) L handles a value; with that, we know whether to apply L or not
 970            depending on whether the current node has a non NULL value or not
 971     */
 972     if (exn == NULL && ! l->consumes_value) {
 973         if (l->atype != NULL && regexp_matches_empty(l->atype)) {
 974             exn = make_exn_value(ref(info),
 975                "optional expression matches the empty tree but does not consume a value");
 976         }
 977     }
 978     return exn;
 979 }
 980
 981 void free_lens(struct lens *lens) {
 982     if (lens == NULL)
 983         return;
 984     ensure(lens->ref == 0, lens->info);
 985
 986     if (debugging("lenses"))
 987         dump_lens_tree(lens);
 988     switch (lens->tag) {
 989     case L_DEL:
 990         unref(lens->regexp, regexp);
 991         unref(lens->string, string);
 992         break;
 993     case L_STORE:
 994     case L_KEY:
 995         unref(lens->regexp, regexp);
 996         break;
 997     case L_LABEL:
 998     case L_SEQ:
 999     case L_COUNTER:
1000     case L_VALUE:
1001         unref(lens->string, string);
1002         break;
1003     case L_SUBTREE:
1004     case L_STAR:
1005     case L_MAYBE:
1006     case L_SQUARE:
1007         unref(lens->child, lens);
1008         break;
1009     case L_CONCAT:
1010     case L_UNION:
1011         for (int i=0; i < lens->nchildren; i++)
1012             unref(lens->children[i], lens);
1013         free(lens->children);
1014         break;
1015     case L_REC:
1016         if (!lens->rec_internal) {
1017             unref(lens->body, lens);
1018         }
1019         break;
1020     default:
1021         BUG_LENS_TAG(lens);
1022         break;
1023     }
1024
1025     for (int t=0; t < ntypes; t++)
1026         unref(ltype(lens, t), regexp);
1027
1028     unref(lens->info, info);
1029     jmt_free(lens->jmt);
1030     free(lens);
1031  error:
1032     return;
1033 }
1034
1035 void lens_release(struct lens *lens) {
1036     if (lens == NULL)
1037         return;
1038
1039     for (int t=0; t < ntypes; t++)
1040         regexp_release(ltype(lens, t));
1041
1042     if (lens->tag == L_KEY || lens->tag == L_STORE)
1043         regexp_release(lens->regexp);
1044
1045     if (lens->tag == L_SUBTREE || lens->tag == L_STAR
1046         || lens->tag == L_MAYBE || lens->tag == L_SQUARE) {
1047         lens_release(lens->child);
1048     }
1049
1050     if (lens->tag == L_UNION || lens->tag == L_CONCAT) {
1051         for (int i=0; i < lens->nchildren; i++) {
1052             lens_release(lens->children[i]);
1053         }
1054     }
1055
1056     jmt_free(lens->jmt);
1057     lens->jmt = NULL;
1058 }
1059
1060 /*
1061  * Encoding of tree levels
1062  */
1063 char *enc_format(const char *e, size_t len) {
1064     return enc_format_indent(e, len, 0);
1065 }
1066
1067 char *enc_format_indent(const char *e, size_t len, int indent) {
1068     size_t size = 0;
1069     char *result = NULL, *r;
1070     const char *k = e;
1071
1072     while (*k && k - e < len) {
1073         char *eq,  *slash, *v;
1074         eq = strchr(k, ENC_EQ_CH);
1075         assert(eq != NULL);
1076         slash = strchr(eq, ENC_SLASH_CH);
1077         assert(slash != NULL);
1078         v = eq + 1;
1079
1080         if (indent > 0)
1081             size += indent + 1;
1082         size += 6;     /* Surrounding braces */
1083         if (k != eq)
1084             size += 1 + (eq - k) + 1;
1085         if (v != slash)
1086             size += 4 + (slash - v) + 1;
1087         k = slash + 1;
1088     }
1089     if (ALLOC_N(result, size + 1) < 0)
1090         return NULL;
1091
1092     k = e;
1093     r = result;
1094     while (*k && k - e < len) {
1095         char *eq,  *slash, *v;
1096         eq = strchr(k, ENC_EQ_CH);
1097         slash = strchr(eq, ENC_SLASH_CH);
1098         assert(eq != NULL && slash != NULL);
1099         v = eq + 1;
1100
1101         for (int i=0; i < indent; i++)
1102             *r++ = ' ';
1103         r = stpcpy(r, " { ");
1104         if (k != eq) {
1105             r = stpcpy(r, "\"");
1106             r = stpncpy(r, k, eq - k);
1107             r = stpcpy(r, "\"");
1108         }
1109         if (v != slash) {
1110             r = stpcpy (r, " = \"");
1111             r = stpncpy(r, v, slash - v);
1112             r = stpcpy(r, "\"");
1113         }
1114         r = stpcpy(r, " }");
1115         if (indent > 0)
1116             *r++ = '\n';
1117         k = slash + 1;
1118     }
1119     return result;
1120 }
1121
1122 static int format_atype(struct lens *l, char **buf, uint indent);
1123
1124 static int format_indent(char **buf, uint indent) {
1125     if (ALLOC_N(*buf, indent+1) < 0)
1126         return -1;
1127     memset(*buf, ' ', indent);
1128     return 0;
1129 }
1130
1131 static int format_subtree_atype(struct lens *l, char **buf, uint indent) {
1132     char *k = NULL, *v = NULL;
1133     const struct regexp *ktype = l->child->ktype;
1134     const struct regexp *vtype = l->child->vtype;
1135     int r, result = -1;
1136     char *si = NULL;
1137
1138     if (format_indent(&si, indent) < 0)
1139         goto done;
1140
1141     if (ktype != NULL) {
1142         k = regexp_escape(ktype);
1143         if (k == NULL)
1144             goto done;
1145     }
1146     if (vtype != NULL) {
1147         v = regexp_escape(vtype);
1148         if (v == NULL)
1149             goto done;
1150         if (k == NULL)
1151             r = xasprintf(buf, "%s{ = /%s/ }", si, k, v);
1152         else
1153             r = xasprintf(buf, "%s{ /%s/ = /%s/ }", si, k, v);
1154     } else {
1155         if (k == NULL)
1156             r = xasprintf(buf, "%s{ }", si, k);
1157         else
1158             r = xasprintf(buf, "%s{ /%s/ }", si, k);
1159     }
1160     if (r < 0)
1161         goto done;
1162
1163     result = 0;
1164  done:
1165     FREE(si);
1166     FREE(v);
1167     FREE(k);
1168     return result;
1169 }
1170
1171 static int format_rep_atype(struct lens *l, char **buf,
1172                             uint indent, char quant) {
1173     char *a = NULL;
1174     int r, result = -1;
1175
1176     r = format_atype(l->child, &a, indent);
1177     if (r < 0)
1178         goto done;
1179     if (strlen(a) == 0) {
1180         *buf = a;
1181         a = NULL;
1182         result = 0;
1183         goto done;
1184     }
1185
1186     if (l->child->tag == L_CONCAT || l->child->tag == L_UNION)
1187         r = xasprintf(buf, "(%s)%c", a, quant);
1188     else
1189         r = xasprintf(buf, "%s%c", a, quant);
1190
1191     if (r < 0)
1192         goto done;
1193
1194     result = 0;
1195  done:
1196     FREE(a);
1197     return result;
1198 }
1199
1200 static int format_concat_atype(struct lens *l, char **buf, uint indent) {
1201     char **c = NULL, *s = NULL, *p;
1202     int r, result = -1;
1203     size_t len = 0, nconc = 0;
1204
1205     if (ALLOC_N(c, l->nchildren) < 0)
1206         goto done;
1207
1208     for (int i=0; i < l->nchildren; i++) {
1209         r = format_atype(l->children[i], c+i, indent);
1210         if (r < 0)
1211             goto done;
1212         len += strlen(c[i]) + 3;
1213         if (strlen(c[i]) > 0)
1214             nconc += 1;
1215         if (l->children[i]->tag == L_UNION)
1216             len += 2;
1217     }
1218
1219     if (ALLOC_N(s, len+1) < 0)
1220         goto done;
1221     p = s;
1222     for (int i=0; i < l->nchildren; i++) {
1223         bool needs_parens = nconc > 1 && l->children[i]->tag == L_UNION;
1224         if (strlen(c[i]) == 0)
1225             continue;
1226         if (i > 0)
1227             *p++ = '\n';
1228         char *t = c[i];
1229         if (needs_parens) {
1230             for (int j=0; j < indent; j++)
1231                 *p++ = *t++;
1232             *p++ = '(';
1233         }
1234         p = stpcpy(p, t);
1235         if (needs_parens)
1236             *p++ = ')';
1237     }
1238
1239     *buf = s;
1240     s = NULL;
1241     result = 0;
1242  done:
1243     if (c != NULL)
1244         for (int i=0; i < l->nchildren; i++)
1245             FREE(c[i]);
1246     FREE(c);
1247     FREE(s);
1248     return result;
1249 }
1250
1251 static int format_union_atype(struct lens *l, char **buf, uint indent) {
1252     char **c = NULL, *s = NULL, *p;
1253     int r, result = -1;
1254     size_t len = 0;
1255
1256     if (ALLOC_N(c, l->nchildren) < 0)
1257         goto done;
1258
1259     /* Estimate the length of the string we will build. The calculation
1260        overestimates that length so that the logic is a little simpler than
1261        in the loop where we actually build the string */
1262     for (int i=0; i < l->nchildren; i++) {
1263         r = format_atype(l->children[i], c+i, indent + 2);
1264         if (r < 0)
1265             goto done;
1266         /* We will add c[i] and some fixed characters */
1267         len += strlen(c[i]) + strlen("\n| ()");
1268         if (strlen(c[i]) < indent+2) {
1269             /* We will add indent+2 whitespace */
1270             len += indent+2;
1271         }
1272     }
1273
1274     if (ALLOC_N(s, len+1) < 0)
1275         goto done;
1276
1277     p = s;
1278     for (int i=0; i < l->nchildren; i++) {
1279         char *t = c[i];
1280         if (i > 0) {
1281             *p++ = '\n';
1282             if (strlen(t) >= indent+2) {
1283                 /* c[i] is not just whitespace */
1284                 p = stpncpy(p, t, indent+2);
1285                 t += indent+2;
1286             } else {
1287                 /* c[i] is just whitespace, make sure we indent the
1288                    '|' appropriately */
1289                 memset(p, ' ', indent+2);
1290                 p += indent+2;
1291             }
1292             p = stpcpy(p, "| ");
1293         } else {
1294             /* Skip additional indent */
1295             t += 2;
1296         }
1297         if (strlen(t) == 0)
1298             p = stpcpy(p, "()");
1299         else
1300             p = stpcpy(p, t);
1301     }
1302     *buf = s;
1303     s = NULL;
1304     result = 0;
1305  done:
1306     if (c != NULL)
1307         for (int i=0; i < l->nchildren; i++)
1308             FREE(c[i]);
1309     FREE(c);
1310     FREE(s);
1311     return result;
1312 }
1313
1314 static int format_rec_atype(struct lens *l, char **buf, uint indent) {
1315     int r;
1316
1317     if (l->rec_internal) {
1318         *buf = strdup("<<rec>>");
1319         return (*buf == NULL) ? -1 : 0;
1320     }
1321
1322     char *c = NULL;
1323     r = format_atype(l->body, &c, indent);
1324     if (r < 0)
1325         return -1;
1326     r = xasprintf(buf, "<<rec:%s>>", c);
1327     free(c);
1328     return (r < 0) ? -1 : 0;
1329 }
1330
1331 static int format_atype(struct lens *l, char **buf, uint indent) {
1332     *buf = NULL;
1333
1334     switch(l->tag) {
1335     case L_DEL:
1336     case L_STORE:
1337     case L_KEY:
1338     case L_LABEL:
1339     case L_VALUE:
1340     case L_SEQ:
1341     case L_COUNTER:
1342         *buf = strdup("");
1343         return (*buf == NULL) ? -1 : 0;
1344         break;
1345     case L_SUBTREE:
1346         return format_subtree_atype(l, buf, indent);
1347         break;
1348     case L_STAR:
1349         return format_rep_atype(l, buf, indent, '*');
1350         break;
1351     case L_MAYBE:
1352         return format_rep_atype(l, buf, indent, '?');
1353         break;
1354     case L_CONCAT:
1355         return format_concat_atype(l, buf, indent);
1356         break;
1357     case L_UNION:
1358         return format_union_atype(l, buf, indent);
1359         break;
1360     case L_REC:
1361         return format_rec_atype(l, buf, indent);
1362         break;
1363     case L_SQUARE:
1364         return format_concat_atype(l->child, buf, indent);
1365         break;
1366     default:
1367         BUG_LENS_TAG(l);
1368         break;
1369     };
1370     return -1;
1371 }
1372
1373 int lns_format_atype(struct lens *l, char **buf) {
1374     int r = 0;
1375     r = format_atype(l, buf, 4);
1376     return r;
1377 }
1378
1379 /*
1380  * Recursive lenses
1381  */
1382 struct value *lns_make_rec(struct info *info) {
1383     struct lens *l = make_lens(L_REC, info);
1384     l->recursive = 1;
1385     l->rec_internal = 1;
1386
1387     return make_lens_value(l);
1388 }
1389
1390 /* Transform a recursive lens into a recursive transition network
1391  *
1392  * First, we transform the lens into context free grammar, considering any
1393  * nonrecursive lens as a terminal
1394  *
1395  * cfg: lens -> nonterminal -> production list
1396  *
1397  * cfg(primitive, N) -> N := regexp(primitive)
1398  * cfg(l1 . l2, N)   -> N := N1 . N2 + cfg(l1, N1) + cfg(l2, N2)
1399  * cfg(l1 | l2, N)   -> N := N1 | N2 + cfg(l1, N1) + cfg(l2, N2)
1400  * cfg(l*, N)        -> N := N . N' | eps + cfg(l, N')
1401  * cfg([ l ], N)     -> N := N' + cfg(l, N')
1402  *
1403  * We use the lenses as nonterminals themselves; this also means that our
1404  * productions are normalized such that the RHS is either a terminal
1405  * (regexp) or entirely consists of nonterminals
1406  *
1407  * In a few places, we need to know that a nonterminal corresponds to a
1408  * subtree combinator ([ l ]); this is the main reason that the rule (cfg[
1409  * l ], N) introduces a useless production N := N'.
1410  *
1411  * Computing the types for a recursive lens r is (fairly) straightforward,
1412  * given the above grammar, which we convert to an automaton following
1413  * http://arxiv.org/abs/cs/9910022; the only complication arises from the
1414  * subtree combinator, since it can be used in recursive lenses to
1415  * construct trees of arbitrary depth, but we need to approximate the types
1416  * of r in a way that fits with our top-down tree automaton in put.c.
1417  *
1418  * To handle subtree combinators, remember that the type rules for a lens
1419  * m = [ l ] are:
1420  *
1421  *   m.ktype = NULL
1422  *   m.vtype = NULL
1423  *   m.ctype = l.ctype
1424  *   m.atype = enc(l.ktype, l.vtype)
1425  *     ( enc is a function regexp -> regexp -> regexp)
1426  *
1427  * We compute types for r by modifying its automaton according to
1428  * Nederhof's paper and reducing it to a regular expression of lenses. This
1429  * has to happen in the following steps:
1430  *   r.ktype : approximate by using [ .. ].ktype = NULL
1431  *   r.vtype : same as r.ktype
1432  *   r.ctype : approximate by treating [ l ] as l
1433  *   r.atype : approximate by using r.ktype and r.vtype from above
1434  *             in lens expressions [ f(r) ]
1435  */
1436
1437 /* Transitions go to a state and are labeled with a lens. For epsilon
1438  * transitions, lens may be NULL. When lens is a simple (nonrecursive
1439  * lens), PROD will be NULL. When we modify the automaton to splice
1440  * nonterminals in, we remember the production for the nonterminal in PROD.
1441  */
1442 struct trans {
1443     struct state  *to;
1444     struct lens   *lens;
1445     struct regexp *re;
1446 };
1447
1448 struct state {
1449     struct state  *next;   /* Linked list for memory management */
1450     size_t         ntrans;
1451     struct trans  *trans;
1452 };
1453
1454 /* Productions for lens LENS. Start state START and end state END. If we
1455    start with START, END is the only accepting state. */
1456 struct prod {
1457     struct lens  *lens;
1458     struct state *start;
1459     struct state *end;
1460 };
1461
1462 /* A recursive transition network used to compute regular approximations
1463  * to the types */
1464 struct rtn {
1465     struct info *info;
1466     size_t        nprod;
1467     struct prod **prod;
1468     struct state *states;  /* Linked list through next of all states in all
1469                               prods; the states for each production are on
1470                               the part of the list from prod->start to
1471                               prod->end */
1472     struct value *exn;
1473     enum lens_type lens_type;
1474     unsigned int check : 1;
1475 };
1476
1477 #define RTN_BAIL(rtn) if ((rtn)->exn != NULL ||                     \
1478                           (rtn)->info->error->code != AUG_NOERROR)  \
1479                          goto error;
1480
1481 static void free_prod(struct prod *prod) {
1482     if (prod == NULL)
1483         return;
1484     unref(prod->lens, lens);
1485     free(prod);
1486 }
1487
1488 static void free_rtn(struct rtn *rtn) {
1489     if (rtn == NULL)
1490         return;
1491     for (int i=0; i < rtn->nprod; i++)
1492         free_prod(rtn->prod[i]);
1493     free(rtn->prod);
1494     list_for_each(s, rtn->states) {
1495         for (int i=0; i < s->ntrans; i++) {
1496             unref(s->trans[i].lens, lens);
1497             unref(s->trans[i].re, regexp);
1498         }
1499         free(s->trans);
1500     }
1501     list_free(rtn->states);
1502     unref(rtn->info, info);
1503     unref(rtn->exn, value);
1504     free(rtn);
1505 }
1506
1507 static struct state *add_state(struct prod *prod) {
1508     struct state *result = NULL;
1509     int r;
1510
1511     r = ALLOC(result);
1512     ERR_NOMEM(r < 0, prod->lens->info);
1513
1514     list_cons(prod->start->next, result);
1515  error:
1516     return result;
1517 }
1518
1519 static struct trans *add_trans(struct rtn *rtn, struct state *state,
1520                                struct state *to, struct lens *l) {
1521     int r;
1522     struct trans *result = NULL;
1523
1524     for (int i=0; i < state->ntrans; i++)
1525         if (state->trans[i].to == to && state->trans[i].lens == l)
1526             return state->trans + i;
1527
1528     r = REALLOC_N(state->trans, state->ntrans+1);
1529     ERR_NOMEM(r < 0, rtn->info);
1530
1531     result = state->trans + state->ntrans;
1532     state->ntrans += 1;
1533
1534     MEMZERO(result, 1);
1535     result->to = to;
1536     if (l != NULL) {
1537         result->lens = ref(l);
1538         result->re = ref(ltype(l, rtn->lens_type));
1539     }
1540  error:
1541     return result;
1542 }
1543
1544 static struct prod *make_prod(struct rtn *rtn, struct lens *l) {
1545     struct prod *result = NULL;
1546     int r;
1547
1548     r = ALLOC(result);
1549     ERR_NOMEM(r < 0, l->info);
1550
1551     result->lens = ref(l);
1552     r = ALLOC(result->start);
1553     ERR_NOMEM(r < 0, l->info);
1554
1555     result->end = add_state(result);
1556     ERR_BAIL(l->info);
1557
1558     result->end->next = rtn->states;
1559     rtn->states = result->start;
1560
1561     return result;
1562  error:
1563     free_prod(result);
1564     return NULL;
1565 }
1566
1567 static struct prod *prod_for_lens(struct rtn *rtn, struct lens *l) {
1568     if (l == NULL)
1569         return NULL;
1570     for (int i=0; i < rtn->nprod; i++) {
1571         if (rtn->prod[i]->lens == l)
1572             return rtn->prod[i];
1573     }
1574     return NULL;
1575 }
1576
1577 static void rtn_dot(struct rtn *rtn, const char *stage) {
1578     FILE *fp;
1579     int r = 0;
1580
1581     fp = debug_fopen("rtn_%s_%s.dot", stage, lens_type_names[rtn->lens_type]);
1582     if (fp == NULL)
1583         return;
1584
1585     fprintf(fp, "digraph \"l1\" {\n  rankdir=LR;\n");
1586     list_for_each(s, rtn->states) {
1587         char *label = NULL;
1588         for (int p=0; p < rtn->nprod; p++) {
1589             if (s == rtn->prod[p]->start) {
1590                 r = xasprintf(&label, "s%d", p);
1591             } else if (s == rtn->prod[p]->end) {
1592                 r = xasprintf(&label, "e%d", p);
1593             }
1594             ERR_NOMEM(r < 0, rtn->info);
1595         }
1596         if (label == NULL) {
1597             r = xasprintf(&label, "%p", s);
1598             ERR_NOMEM(r < 0, rtn->info);
1599         }
1600         fprintf(fp, "  n%p [label = \"%s\"];\n", s, label == NULL ? "" : label);
1601         FREE(label);
1602         for (int i=0; i < s->ntrans; i++) {
1603             fprintf(fp, "  n%p -> n%p", s, s->trans[i].to);
1604             if (s->trans[i].re != NULL) {
1605                 label = regexp_escape(s->trans[i].re);
1606                 for (char *t = label; *t; t++)
1607                     if (*t == '\\')
1608                         *t = '~';
1609                 fprintf(fp, " [ label = \"%s\" ]", label);
1610                 FREE(label);
1611             }
1612             fprintf(fp, ";\n");
1613         }
1614     }
1615  error:
1616     fprintf(fp, "}\n");
1617     fclose(fp);
1618 }
1619
1620 /* Add transitions to RTN corresponding to cfg(l, N) */
1621 static void rtn_rules(struct rtn *rtn, struct lens *l) {
1622     if (! l->recursive)
1623         return;
1624
1625     struct prod *prod = prod_for_lens(rtn, l);
1626     if (prod != NULL)
1627         return;
1628
1629     int r = REALLOC_N(rtn->prod, rtn->nprod+1);
1630     ERR_NOMEM(r < 0, l->info);
1631
1632     prod =  make_prod(rtn, l);
1633     rtn->prod[rtn->nprod] = prod;
1634     RTN_BAIL(rtn);
1635     rtn->nprod += 1;
1636
1637     struct state *start = prod->start;
1638
1639     switch (l->tag) {
1640     case L_UNION:
1641         /* cfg(l1|..|ln, N) -> N := N1 | N2 | ... | Nn */
1642         for (int i=0; i < l->nchildren; i++) {
1643             add_trans(rtn, start, prod->end, l->children[i]);
1644             RTN_BAIL(rtn);
1645             rtn_rules(rtn, l->children[i]);
1646             RTN_BAIL(rtn);
1647         }
1648         break;
1649     case L_CONCAT:
1650         /* cfg(l1 . l2 ... ln, N) -> N := N1 . N2 ... Nn */
1651         for (int i=0; i < l->nchildren-1; i++) {
1652             struct state *s = add_state(prod);
1653             RTN_BAIL(rtn);
1654             add_trans(rtn, start, s, l->children[i]);
1655             RTN_BAIL(rtn);
1656             start = s;
1657             rtn_rules(rtn, l->children[i]);
1658             RTN_BAIL(rtn);
1659         }
1660         {
1661             struct lens *c = l->children[l->nchildren - 1];
1662             add_trans(rtn, start, prod->end, c);
1663             RTN_BAIL(rtn);
1664             rtn_rules(rtn, c);
1665             RTN_BAIL(rtn);
1666         }
1667         break;
1668     case L_STAR: {
1669         /* cfg(l*, N) -> N := N . N' | eps */
1670         struct state *s = add_state(prod);
1671         RTN_BAIL(rtn);
1672         add_trans(rtn, start, s, l);
1673         RTN_BAIL(rtn);
1674         add_trans(rtn, s, prod->end, l->child);
1675         RTN_BAIL(rtn);
1676         add_trans(rtn, start, prod->end, NULL);
1677         RTN_BAIL(rtn);
1678         rtn_rules(rtn, l->child);
1679         RTN_BAIL(rtn);
1680         break;
1681     }
1682     case L_SUBTREE:
1683         switch (rtn->lens_type) {
1684         case KTYPE:
1685         case VTYPE:
1686             /* cfg([ l ], N) -> N := eps */
1687             add_trans(rtn, start, prod->end, NULL);
1688             break;
1689         case CTYPE:
1690             /* cfg([ l ], N) -> N := N' plus cfg(l, N') */
1691             add_trans(rtn, start, prod->end, l->child);
1692             RTN_BAIL(rtn);
1693             rtn_rules(rtn, l->child);
1694             RTN_BAIL(rtn);
1695             break;
1696         case ATYPE: {
1697             /* At this point, we have propagated ktype and vtype */
1698             /* cfg([ l ], N) -> N := enc(l->ktype, l->vtype) */
1699             struct trans *t = add_trans(rtn, start, prod->end, NULL);
1700             RTN_BAIL(rtn);
1701             t->re = subtree_atype(l->info, l->child->ktype, l->child->vtype);
1702             break;
1703         }
1704         default:
1705             BUG_ON(true, rtn->info, "Unexpected lens type %d", rtn->lens_type);
1706             break;
1707         }
1708         break;
1709     case L_MAYBE:
1710         /* cfg(l?, N) -> N := N' | eps plus cfg(l, N') */
1711         add_trans(rtn, start, prod->end, l->child);
1712         RTN_BAIL(rtn);
1713         add_trans(rtn, start, prod->end, NULL);
1714         RTN_BAIL(rtn);
1715         rtn_rules(rtn, l->child);
1716         RTN_BAIL(rtn);
1717         break;
1718     case L_REC:
1719         /* cfg(l, N) -> N := N' plus cfg(l->body, N') */
1720         add_trans(rtn, start, prod->end, l->body);
1721         RTN_BAIL(rtn);
1722         rtn_rules(rtn, l->body);
1723         RTN_BAIL(rtn);
1724         break;
1725     case L_SQUARE:
1726         add_trans(rtn, start, prod->end, l->child);
1727         RTN_BAIL(rtn);
1728         break;
1729     default:
1730         BUG_LENS_TAG(l);
1731         break;
1732     }
1733  error:
1734     return;
1735 }
1736
1737 /* Replace transition t with two epsilon transitions s => p->start and
1738  * p->end => s->trans[i].to where s is the start of t. Instead of adding
1739  * epsilon transitions, we expand the epsilon transitions.
1740  */
1741 static void prod_splice(struct rtn *rtn,
1742                         struct prod *from, struct prod *to, struct trans *t) {
1743
1744     add_trans(rtn, to->end, t->to, NULL);
1745     ERR_BAIL(from->lens->info);
1746     t->to = to->start;
1747     unref(t->re, regexp);
1748
1749  error:
1750     return;
1751 }
1752
1753 static void rtn_splice(struct rtn *rtn, struct prod *prod) {
1754     for (struct state *s = prod->start; s != prod->end; s = s->next) {
1755         for (int i=0; i < s->ntrans; i++) {
1756             struct prod *p = prod_for_lens(rtn, s->trans[i].lens);
1757             if (p != NULL) {
1758                 prod_splice(rtn, prod, p, s->trans+i);
1759                 RTN_BAIL(rtn);
1760             }
1761         }
1762     }
1763  error:
1764     return;
1765 }
1766
1767 static struct rtn *rtn_build(struct lens *rec, enum lens_type lt) {
1768     int r;
1769     struct rtn *rtn;
1770
1771     r = ALLOC(rtn);
1772     ERR_NOMEM(r < 0, rec->info);
1773
1774     rtn->info = ref(rec->info);
1775     rtn->lens_type = lt;
1776
1777     rtn_rules(rtn, rec);
1778     RTN_BAIL(rtn);
1779     if (debugging("cf.approx"))
1780         rtn_dot(rtn, "10-rules");
1781
1782     for (int i=0; i < rtn->nprod; i++) {
1783         rtn_splice(rtn, rtn->prod[i]);
1784         RTN_BAIL(rtn);
1785     }
1786     if (debugging("cf.approx"))
1787         rtn_dot(rtn, "11-splice");
1788
1789  error:
1790     return rtn;
1791 }
1792
1793 /* Compare transitions lexicographically by (to, lens) */
1794 static int trans_to_cmp(const void *v1, const void *v2) {
1795     const struct trans *t1 = v1;
1796     const struct trans *t2 = v2;
1797
1798     if (t1->to != t2->to)
1799         return (t1->to < t2->to) ? -1 : 1;
1800
1801     if (t1->lens == t2->lens)
1802         return 0;
1803     return (t1->lens < t2->lens) ? -1 : 1;
1804 }
1805
1806 /* Collapse a transition S1 -> S -> S2 by adding a transition S1 -> S2 with
1807  * lens R1 . (LOOP)* . R2 | R3 where R3 is the regexp on the possibly
1808  * existing transition S1 -> S2. If LOOP is NULL or R3 does not exist,
1809  * label the transition with a simplified regexp by treating NULL as
1810  * epsilon */
1811 static void collapse_trans(struct rtn *rtn,
1812                            struct state *s1, struct state *s2,
1813                            struct regexp *r1, struct regexp *loop,
1814                            struct regexp *r2) {
1815
1816     struct trans *t = NULL;
1817     struct regexp *r = NULL;
1818
1819     for (int i=0; i < s1->ntrans; i++) {
1820         if (s1->trans[i].to == s2) {
1821             t = s1->trans + i;
1822             break;
1823         }
1824     }
1825
1826     /* Set R = R1 . (LOOP)* . R2, treating NULL's as epsilon */
1827     if (loop == NULL) {
1828         if (r1 == NULL)
1829             r = ref(r2);
1830         else if (r2 == NULL)
1831             r = ref(r1);
1832         else
1833             r = regexp_concat(rtn->info, r1, r2);
1834     } else {
1835         struct regexp *s = regexp_iter(rtn->info, loop, 0, -1);
1836         ERR_NOMEM(s == NULL, rtn->info);
1837         struct regexp *c = NULL;
1838         if (r1 == NULL) {
1839             c = s;
1840             s = NULL;
1841         } else {
1842             c = regexp_concat(rtn->info, r1, s);
1843             unref(s, regexp);
1844             ERR_NOMEM(c == NULL, rtn->info);
1845         }
1846         if (r2 == NULL) {
1847             r = c;
1848             c = NULL;
1849         } else {
1850             r = regexp_concat(rtn->info, c, r2);
1851             unref(c, regexp);
1852             ERR_NOMEM(r == NULL, rtn->info);
1853         }
1854     }
1855
1856     if (t == NULL) {
1857         t = add_trans(rtn, s1, s2, NULL);
1858         ERR_NOMEM(t == NULL, rtn->info);
1859         t->re = r;
1860     } else if (t->re == NULL) {
1861         if (r == NULL || regexp_matches_empty(r))
1862             t->re = r;
1863         else {
1864             t->re = regexp_maybe(rtn->info, r);
1865             unref(r, regexp);
1866             ERR_NOMEM(t->re == NULL, rtn->info);
1867         }
1868     } else if (r == NULL) {
1869         if (!regexp_matches_empty(t->re)) {
1870             r = regexp_maybe(rtn->info, t->re);
1871             unref(t->re, regexp);
1872             t->re = r;
1873             ERR_NOMEM(r == NULL, rtn->info);
1874         }
1875     } else {
1876         struct regexp *u = regexp_union(rtn->info, r, t->re);
1877         unref(r, regexp);
1878         unref(t->re, regexp);
1879         t->re = u;
1880         ERR_NOMEM(u == NULL, rtn->info);
1881     }
1882
1883     return;
1884  error:
1885     rtn->exn = rtn->info->error->exn;
1886     return;
1887 }
1888
1889 /* Reduce the automaton with start state rprod->start and only accepting
1890  * state rprod->end so that we have a single transition rprod->start =>
1891  * rprod->end labelled with the overall approximating regexp for the
1892  * automaton.
1893  *
1894  * This is the same algorithm as fa_as_regexp in fa.c
1895  */
1896 static struct regexp *rtn_reduce(struct rtn *rtn, struct lens *rec) {
1897     struct prod *prod = prod_for_lens(rtn, rec);
1898     int r;
1899
1900     ERR_THROW(prod == NULL, rtn->info, AUG_EINTERNAL,
1901               "No production for recursive lens");
1902
1903     /* Eliminate epsilon transitions and turn transitions between the same
1904      * two states into a regexp union */
1905     list_for_each(s, rtn->states) {
1906         qsort(s->trans, s->ntrans, sizeof(*s->trans), trans_to_cmp);
1907         for (int i=0; i < s->ntrans; i++) {
1908             int j = i+1;
1909             for (;j < s->ntrans && s->trans[i].to == s->trans[j].to;
1910                  j++);
1911             if (j > i+1) {
1912                 struct regexp *u, **v;
1913                 r = ALLOC_N(v, j - i);
1914                 ERR_NOMEM(r < 0, rtn->info);
1915                 for (int k=i; k < j; k++)
1916                     v[k-i] = s->trans[k].re;
1917                 u = regexp_union_n(rtn->info, j - i, v);
1918                 if (u == NULL) {
1919                     // FIXME: The calling convention for regexp_union_n
1920                     // is bad, since we can't distinguish between alloc
1921                     // failure and unioning all NULL's
1922                     for (int k=0; k < j-i; k++)
1923                         if (v[k] != NULL) {
1924                             FREE(v);
1925                             ERR_NOMEM(true, rtn->info);
1926                         }
1927                 }
1928                 FREE(v);
1929                 for (int k=i; k < j; k++) {
1930                     unref(s->trans[k].lens, lens);
1931                     unref(s->trans[k].re, regexp);
1932                 }
1933                 s->trans[i].re = u;
1934                 MEMMOVE(s->trans + (i+1),
1935                         s->trans + j,
1936                         s->ntrans - j);
1937                 s->ntrans -= j - (i + 1);
1938             }
1939         }
1940     }
1941
1942     /* Introduce new start and end states with epsilon transitions to/from
1943      * the old start and end states */
1944     struct state *end = NULL;
1945     struct state *start = NULL;
1946     if (ALLOC(start) < 0 || ALLOC(end) < 0) {
1947         FREE(start);
1948         FREE(end);
1949         ERR_NOMEM(true, rtn->info);
1950     }
1951     list_insert_before(start, prod->start, rtn->states);
1952     end->next = prod->end->next;
1953     prod->end->next = end;
1954
1955     add_trans(rtn, start, prod->start, NULL);
1956     RTN_BAIL(rtn);
1957     add_trans(rtn, prod->end, end, NULL);
1958     RTN_BAIL(rtn);
1959
1960     prod->start = start;
1961     prod->end = end;
1962
1963     /* Eliminate states S (except for INI and FIN) one by one:
1964      *     Let LOOP the regexp for the transition S -> S if it exists, epsilon
1965      *     otherwise.
1966      *     For all S1, S2 different from S with S1 -> S -> S2
1967      *       Let R1 the regexp of S1 -> S
1968      *           R2 the regexp of S -> S2
1969      *           R3 the regexp of S1 -> S2 (or the regexp matching nothing
1970      *                                      if no such transition)
1971      *        set the regexp on the transition S1 -> S2 to
1972      *          R1 . (LOOP)* . R2 | R3 */
1973     // FIXME: This does not go over all states
1974     list_for_each(s, rtn->states) {
1975         if (s == prod->end || s == prod->start)
1976             continue;
1977         struct regexp *loop = NULL;
1978         for (int i=0; i < s->ntrans; i++) {
1979             if (s == s->trans[i].to) {
1980                 ensure(loop == NULL, rtn->info);
1981                 loop = s->trans[i].re;
1982             }
1983         }
1984         list_for_each(s1, rtn->states) {
1985             if (s == s1)
1986                 continue;
1987             for (int t1=0; t1 < s1->ntrans; t1++) {
1988                 if (s == s1->trans[t1].to) {
1989                     for (int t2=0; t2 < s->ntrans; t2++) {
1990                         struct state *s2 = s->trans[t2].to;
1991                         if (s2 == s)
1992                             continue;
1993                         collapse_trans(rtn, s1, s2,
1994                                        s1->trans[t1].re, loop,
1995                                        s->trans[t2].re);
1996                         RTN_BAIL(rtn);
1997                     }
1998                 }
1999             }
2000         }
2001     }
2002
2003     /* Find the overall regexp */
2004     struct regexp *result = NULL;
2005     for (int i=0; i < prod->start->ntrans; i++) {
2006         if (prod->start->trans[i].to == prod->end) {
2007             ensure(result == NULL, rtn->info);
2008             result = ref(prod->start->trans[i].re);
2009         }
2010     }
2011     return result;
2012  error:
2013     return NULL;
2014 }
2015
2016 static void propagate_type(struct lens *l, enum lens_type lt) {
2017     struct regexp **types = NULL;
2018     int r;
2019
2020     if (! l->recursive || ltype(l, lt) != NULL)
2021         return;
2022
2023     switch(l->tag) {
2024     case L_CONCAT:
2025         r = ALLOC_N(types, l->nchildren);
2026         ERR_NOMEM(r < 0, l->info);
2027         for (int i=0; i < l->nchildren; i++) {
2028             propagate_type(l->children[i], lt);
2029             types[i] = ltype(l->children[i], lt);
2030         }
2031         ltype(l, lt) = regexp_concat_n(l->info, l->nchildren, types);
2032         FREE(types);
2033         break;
2034     case L_UNION:
2035         r = ALLOC_N(types, l->nchildren);
2036         ERR_NOMEM(r < 0, l->info);
2037         for (int i=0; i < l->nchildren; i++) {
2038             propagate_type(l->children[i], lt);
2039             types[i] = ltype(l->children[i], lt);
2040         }
2041         ltype(l, lt) = regexp_union_n(l->info, l->nchildren, types);
2042         FREE(types);
2043         break;
2044     case L_SUBTREE:
2045         propagate_type(l->child, lt);
2046         if (lt == ATYPE)
2047             l->atype = subtree_atype(l->info, l->child->ktype, l->child->vtype);
2048         if (lt == CTYPE)
2049             l->ctype = ref(l->child->ctype);
2050         break;
2051     case L_STAR:
2052         propagate_type(l->child, lt);
2053         ltype(l, lt) = regexp_iter(l->info, ltype(l->child, lt), 0, -1);
2054         break;
2055     case L_MAYBE:
2056         propagate_type(l->child, lt);
2057         ltype(l, lt) = regexp_maybe(l->info, ltype(l->child, lt));
2058         break;
2059     case L_REC:
2060         /* Nothing to do */
2061         break;
2062     case L_SQUARE:
2063         propagate_type(l->child, lt);
2064         ltype(l, lt) = ref(ltype(l->child, lt));
2065         break;
2066     default:
2067         BUG_LENS_TAG(l);
2068         break;
2069     }
2070
2071  error:
2072     FREE(types);
2073 }
2074
2075 static struct value *typecheck(struct lens *l, int check);
2076
2077 typedef struct value *typecheck_n_make(struct info *,
2078                                        struct lens *, struct lens *, int);
2079
2080 static struct info *merge_info(struct info *i1, struct info *i2) {
2081     struct info *info;
2082     make_ref(info);
2083     ERR_NOMEM(info == NULL, i1);
2084
2085     info->filename = ref(i1->filename);
2086     info->first_line = i1->first_line;
2087     info->first_column = i1->first_column;
2088     info->last_line    = i2->last_line;
2089     info->last_column  = i2->last_column;
2090     info->error        = i1->error;
2091     return info;
2092
2093  error:
2094     unref(info, info);
2095     return NULL;
2096 }
2097
2098 static struct value *typecheck_n(struct lens *l,
2099                                  typecheck_n_make *make, int check) {
2100     struct value *exn = NULL;
2101     struct lens *acc = NULL;
2102
2103     ensure(l->tag == L_CONCAT || l->tag == L_UNION, l->info);
2104     for (int i=0; i < l->nchildren; i++) {
2105         exn = typecheck(l->children[i], check);
2106         if (exn != NULL)
2107             goto error;
2108     }
2109     acc = ref(l->children[0]);
2110     for (int i=1; i < l->nchildren; i++) {
2111         struct info *info = merge_info(acc->info, l->children[i]->info);
2112         ERR_BAIL(acc->info);
2113         exn = (*make)(info, acc, ref(l->children[i]), check);
2114         if (EXN(exn))
2115             goto error;
2116         ensure(exn->tag == V_LENS, l->info);
2117         acc = ref(exn->lens);
2118         unref(exn, value);
2119     }
2120     l->value = acc->value;
2121     l->key = acc->key;
2122  error:
2123     unref(acc, lens);
2124     return exn;
2125 }
2126
2127 static struct value *typecheck(struct lens *l, int check) {
2128     struct value *exn = NULL;
2129
2130     /* Nonrecursive lenses are typechecked at build time */
2131     if (! l->recursive)
2132         return NULL;
2133
2134     switch(l->tag) {
2135     case L_CONCAT:
2136         exn = typecheck_n(l, lns_make_concat, check);
2137         break;
2138     case L_UNION:
2139         exn = typecheck_n(l, lns_make_union, check);
2140         break;
2141     case L_SUBTREE:
2142     case L_SQUARE:
2143         exn = typecheck(l->child, check);
2144         break;
2145     case L_STAR:
2146         if (check)
2147             exn = typecheck_iter(l->info, l->child);
2148         if (exn == NULL && l->value)
2149             exn = make_exn_value(l->info, "Multiple stores in iteration");
2150         if (exn == NULL && l->key)
2151             exn = make_exn_value(l->info, "Multiple keys/labels in iteration");
2152         break;
2153     case L_MAYBE:
2154         if (check)
2155             exn = typecheck_maybe(l->info, l->child);
2156         l->key = l->child->key;
2157         l->value = l->child->value;
2158         break;
2159     case L_REC:
2160         /* Nothing to do */
2161         break;
2162     default:
2163         BUG_LENS_TAG(l);
2164         break;
2165     }
2166
2167     return exn;
2168 }
2169
2170 static struct value *rtn_approx(struct lens *rec, enum lens_type lt) {
2171     struct rtn *rtn = NULL;
2172     struct value *result = NULL;
2173
2174     rtn = rtn_build(rec, lt);
2175     RTN_BAIL(rtn);
2176     ltype(rec, lt) = rtn_reduce(rtn, rec);
2177     RTN_BAIL(rtn);
2178     if (debugging("cf.approx"))
2179         rtn_dot(rtn, "50-reduce");
2180
2181     propagate_type(rec->body, lt);
2182     ERR_BAIL(rec->info);
2183
2184  done:
2185     free_rtn(rtn);
2186
2187     if (debugging("cf.approx")) {
2188         printf("approx %s  => ", lens_type_names[lt]);
2189         print_regexp(stdout, ltype(rec, lt));
2190         printf("\n");
2191     }
2192
2193     return result;
2194  error:
2195     if (rtn->exn == NULL)
2196         result = rec->info->error->exn;
2197     else
2198         result = ref(rtn->exn);
2199     goto done;
2200 }
2201
2202 static struct value *
2203 exn_multiple_epsilons(struct lens *lens,
2204                       struct lens *l1, struct lens *l2) {
2205     char *fi = NULL;
2206     struct value *exn = NULL;
2207
2208     exn = make_exn_value(ref(lens->info),
2209                          "more than one nullable branch in a union");
2210     fi = format_info(l1->info);
2211     exn_printf_line(exn, "First nullable lens: %s", fi);
2212     FREE(fi);
2213
2214     fi = format_info(l2->info);
2215     exn_printf_line(exn, "Second nullable lens: %s", fi);
2216     FREE(fi);
2217
2218     return exn;
2219 }
2220
2221 /* Update lens->ctype_nullable and return 1 if there was a change,
2222  * 0 if there was none */
2223 static int ctype_nullable(struct lens *lens, struct value **exn) {
2224     int nullable = 0;
2225     int ret = 0;
2226     struct lens *null_lens = NULL;
2227
2228     if (! lens->recursive)
2229         return 0;
2230
2231     switch(lens->tag) {
2232     case L_CONCAT:
2233         nullable = 1;
2234         for (int i=0; i < lens->nchildren; i++) {
2235             if (ctype_nullable(lens->children[i], exn))
2236                 ret = 1;
2237             if (! lens->children[i]->ctype_nullable)
2238                 nullable = 0;
2239         }
2240         break;
2241     case L_UNION:
2242         for (int i=0; i < lens->nchildren; i++) {
2243             if (ctype_nullable(lens->children[i], exn))
2244                 ret = 1;
2245             if (lens->children[i]->ctype_nullable) {
2246                 if (nullable) {
2247                     *exn = exn_multiple_epsilons(lens, null_lens,
2248                                                  lens->children[i]);
2249                     return 0;
2250                 }
2251                 nullable = 1;
2252                 null_lens = lens->children[i];
2253             }
2254         }
2255         break;
2256     case L_SUBTREE:
2257     case L_SQUARE:
2258         ret = ctype_nullable(lens->child, exn);
2259         nullable = lens->child->ctype_nullable;
2260         break;
2261     case L_STAR:
2262     case L_MAYBE:
2263         nullable = 1;
2264         break;
2265     case L_REC:
2266         nullable = lens->body->ctype_nullable;
2267         break;
2268     default:
2269         BUG_LENS_TAG(lens);
2270         break;
2271     }
2272     if (*exn != NULL)
2273         return 0;
2274     if (nullable != lens->ctype_nullable) {
2275         ret = 1;
2276         lens->ctype_nullable = nullable;
2277     }
2278     return ret;
2279 }
2280
2281 struct value *lns_check_rec(struct info *info,
2282                             struct lens *body, struct lens *rec,
2283                             int check) {
2284     /* The types in the order of approximation */
2285     static const enum lens_type types[] = { KTYPE, VTYPE, ATYPE };
2286     struct value *result = NULL;
2287
2288     ensure(rec->tag == L_REC, info);
2289     ensure(rec->rec_internal, info);
2290
2291     /* The user might have written down a regular lens with 'let rec' */
2292     if (! body->recursive) {
2293         result = make_lens_value(ref(body));
2294         ERR_NOMEM(result == NULL, info);
2295         return result;
2296     }
2297
2298     /* To help memory management, we avoid the cycle inherent ina recursive
2299      * lens by using two instances of an L_REC lens. One is marked with
2300      * rec_internal, and used inside the body of the lens. The other is the
2301      * "toplevel" which receives external references.
2302      *
2303      * The internal instance of the recursive lens is REC, the external one
2304      * is TOP, constructed below
2305      */
2306     rec->body = body;                          /* REC does not own BODY */
2307
2308     for (int i=0; i < ARRAY_CARDINALITY(types); i++) {
2309         result = rtn_approx(rec, types[i]);
2310         ERR_BAIL(info);
2311     }
2312
2313     if (rec->atype == NULL) {
2314         result = make_exn_value(ref(rec->info),
2315         "recursive lens generates the empty language for its %s",
2316          rec->ctype == NULL ? "ctype" : "atype");
2317         goto error;
2318     }
2319
2320     rec->key = rec->body->key;
2321     rec->value = rec->body->value;
2322     rec->consumes_value = rec->body->consumes_value;
2323
2324     while(ctype_nullable(rec->body, &result));
2325     if (result != NULL)
2326         goto error;
2327     rec->ctype_nullable = rec->body->ctype_nullable;
2328
2329     result = typecheck(rec->body, check);
2330     if (result != NULL)
2331         goto error;
2332
2333     result = lns_make_rec(ref(rec->info));
2334     struct lens *top = result->lens;
2335     for (int t=0; t < ntypes; t++)
2336         ltype(top, t) = ref(ltype(rec, t));
2337     top->value = rec->value;
2338     top->key = rec->key;
2339     top->consumes_value = rec->consumes_value;
2340     top->ctype_nullable = rec->ctype_nullable;
2341     top->body = ref(body);
2342     top->alias = rec;
2343     top->rec_internal = 0;
2344     rec->alias = top;
2345
2346     top->jmt = jmt_build(top);
2347     ERR_BAIL(info);
2348
2349     return result;
2350  error:
2351     if (result != NULL && result->tag != V_EXN)
2352         unref(result, value);
2353     if (result == NULL)
2354         result = info->error->exn;
2355     return result;
2356 }
2357
2358 #if ENABLE_DEBUG
2359 void dump_lens_tree(struct lens *lens){
2360     static int count = 0;
2361     FILE *fp;
2362
2363     fp = debug_fopen("lens_%02d_%s.dot", count++, ltag(lens));
2364     if (fp == NULL)
2365         return;
2366
2367     fprintf(fp, "digraph \"%s\" {\n", "lens");
2368     dump_lens(fp, lens);
2369     fprintf(fp, "}\n");
2370
2371     fclose(fp);
2372 }
2373
2374 void dump_lens(FILE *out, struct lens *lens){
2375     int i = 0;
2376     struct regexp *re;
2377
2378     fprintf(out, "\"%p\" [ shape = box, label = \"%s\\n", lens, ltag(lens));
2379
2380     for (int t=0; t < ntypes; t++) {
2381         re = ltype(lens, t);
2382         if (re == NULL)
2383             continue;
2384         fprintf(out, "%s=",lens_type_names[t]);
2385         print_regexp(out, re);
2386         fprintf(out, "\\n");
2387     }
2388
2389     fprintf(out, "recursive=%x\\n", lens->recursive);
2390     fprintf(out, "rec_internal=%x\\n", lens->rec_internal);
2391     fprintf(out, "consumes_value=%x\\n", lens->consumes_value);
2392     fprintf(out, "ctype_nullable=%x\\n", lens->ctype_nullable);
2393     fprintf(out, "\"];\n");
2394     switch(lens->tag){
2395     case L_DEL:
2396         break;
2397     case L_STORE:
2398         break;
2399     case L_VALUE:
2400         break;
2401     case L_KEY:
2402         break;
2403     case L_LABEL:
2404         break;
2405     case L_SEQ:
2406         break;
2407     case L_COUNTER:
2408         break;
2409     case L_CONCAT:
2410         for(i = 0; i<lens->nchildren;i++){
2411             fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->children[i]);
2412             dump_lens(out, lens->children[i]);
2413         }
2414         break;
2415     case L_UNION:
2416         for(i = 0; i<lens->nchildren;i++){
2417             fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->children[i]);
2418             dump_lens(out, lens->children[i]);
2419         }
2420         break;
2421     case L_SUBTREE:
2422         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2423         dump_lens(out, lens->child);
2424         break;
2425     case L_STAR:
2426         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2427         dump_lens(out, lens->child);
2428
2429         break;
2430     case L_MAYBE:
2431         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2432         dump_lens(out, lens->child);
2433
2434         break;
2435     case L_REC:
2436         if (lens->rec_internal == 0){
2437             fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2438             dump_lens(out, lens->body);
2439         }
2440         break;
2441     case L_SQUARE:
2442         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2443         dump_lens(out, lens->child);
2444         break;
2445     default:
2446         fprintf(out, "ERROR\n");
2447         break;
2448     }
2449 }
2450 #endif
2451
2452 /*
2453  * Local variables:
2454  *  indent-tabs-mode: nil
2455  *  c-indent-level: 4
2456  *  c-basic-offset: 4
2457  *  tab-width: 4
2458  * End:
2459  */