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