src/lens.c

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