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