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