src/syntax.c

   1 /*
   2  * syntax.c:
   3  *
   4  * Copyright (C) 2007-2011 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
  25 #include <assert.h>
  26 #include <stdarg.h>
  27 #include <limits.h>
  28 #include <ctype.h>
  29 #include <glob.h>
  30 #include <argz.h>
  31 #include <sys/types.h>
  32 #include <sys/stat.h>
  33 #include <unistd.h>
  34
  35 #include "memory.h"
  36 #include "syntax.h"
  37 #include "augeas.h"
  38 #include "transform.h"
  39 #include "errcode.h"
  40
  41 /* Extension of source files */
  42 #define AUG_EXT ".aug"
  43
  44 #define LNS_TYPE_CHECK(ctx) ((ctx)->aug->flags & AUG_TYPE_CHECK)
  45
  46 static const char *const builtin_module = "Builtin";
  47
  48 static const struct type string_type    = { .ref = UINT_MAX, .tag = T_STRING };
  49 static const struct type regexp_type    = { .ref = UINT_MAX, .tag = T_REGEXP };
  50 static const struct type lens_type      = { .ref = UINT_MAX, .tag = T_LENS };
  51 static const struct type tree_type      = { .ref = UINT_MAX, .tag = T_TREE };
  52 static const struct type filter_type    = { .ref = UINT_MAX, .tag = T_FILTER };
  53 static const struct type transform_type =
  54                                        { .ref = UINT_MAX, .tag = T_TRANSFORM };
  55 static const struct type unit_type      = { .ref = UINT_MAX, .tag = T_UNIT };
  56
  57 const struct type *const t_string    = &string_type;
  58 const struct type *const t_regexp    = &regexp_type;
  59 const struct type *const t_lens      = &lens_type;
  60 const struct type *const t_tree      = &tree_type;
  61 const struct type *const t_filter    = &filter_type;
  62 const struct type *const t_transform = &transform_type;
  63 const struct type *const t_unit      = &unit_type;
  64
  65 static const char *const type_names[] = {
  66     "string", "regexp", "lens", "tree", "filter",
  67     "transform", "function", "unit", NULL
  68 };
  69
  70 /* The anonymous identifier which we will never bind */
  71 static const char const anon_ident[] = "_";
  72
  73 static void print_value(FILE *out, struct value *v);
  74
  75 /* The evaluation context with all loaded modules and the bindings for the
  76  * module we are working on in LOCAL
  77  */
  78 struct ctx {
  79     const char     *name;     /* The module we are working on */
  80     struct augeas  *aug;
  81     struct binding *local;
  82 };
  83
  84 static int init_fatal_exn(struct error *error) {
  85     if (error->exn != NULL)
  86         return 0;
  87     error->exn = make_exn_value(ref(error->info), "Error during evaluation");
  88     if (error->exn == NULL)
  89         return -1;
  90     error->exn->exn->seen = 1;
  91     error->exn->exn->error = 1;
  92     error->exn->exn->lines = NULL;
  93     error->exn->exn->nlines = 0;
  94     error->exn->ref = REF_MAX;
  95     return 0;
  96 }
  97
  98 static void format_error(struct info *info, aug_errcode_t code,
  99                          const char *format, va_list ap) {
 100     struct error *error = info->error;
 101     char *si = NULL, *sf = NULL, *sd = NULL;
 102     int r;
 103
 104     error->code = code;
 105     /* Only syntax errors are cumulative */
 106     if (code != AUG_ESYNTAX)
 107         FREE(error->details);
 108
 109     si = format_info(info);
 110     r = vasprintf(&sf, format, ap);
 111     if (r < 0)
 112         sf = NULL;
 113     if (error->details != NULL) {
 114         r = xasprintf(&sd, "%s\n%s%s", error->details,
 115                       (si == NULL) ? "(no location)" : si,
 116                       (sf == NULL) ? "(no details)" : sf);
 117     } else {
 118         r = xasprintf(&sd, "%s%s",
 119                       (si == NULL) ? "(no location)" : si,
 120                       (sf == NULL) ? "(no details)" : sf);
 121     }
 122     if (r >= 0) {
 123         free(error->details);
 124         error->details = sd;
 125     }
 126     free(si);
 127     free(sf);
 128 }
 129
 130 void syntax_error(struct info *info, const char *format, ...) {
 131     struct error *error = info->error;
 132     va_list ap;
 133
 134     if (error->code != AUG_NOERROR && error->code != AUG_ESYNTAX)
 135         return;
 136
 137         va_start(ap, format);
 138     format_error(info, AUG_ESYNTAX, format, ap);
 139     va_end(ap);
 140 }
 141
 142 void fatal_error(struct info *info, const char *format, ...) {
 143     struct error *error = info->error;
 144     va_list ap;
 145
 146     if (error->code == AUG_EINTERNAL)
 147         return;
 148
 149         va_start(ap, format);
 150     format_error(info, AUG_EINTERNAL, format, ap);
 151     va_end(ap);
 152 }
 153
 154 static void free_param(struct param *param) {
 155     if (param == NULL)
 156         return;
 157     assert(param->ref == 0);
 158     unref(param->info, info);
 159     unref(param->name, string);
 160     unref(param->type, type);
 161     free(param);
 162 }
 163
 164 void free_term(struct term *term) {
 165     if (term == NULL)
 166         return;
 167     assert(term->ref == 0);
 168     switch(term->tag) {
 169     case A_MODULE:
 170         free(term->mname);
 171         free(term->autoload);
 172         unref(term->decls, term);
 173         break;
 174     case A_BIND:
 175         free(term->bname);
 176         unref(term->exp, term);
 177         break;
 178     case A_COMPOSE:
 179     case A_UNION:
 180     case A_MINUS:
 181     case A_CONCAT:
 182     case A_APP:
 183     case A_LET:
 184         unref(term->left, term);
 185         unref(term->right, term);
 186         break;
 187     case A_VALUE:
 188         unref(term->value, value);
 189         break;
 190     case A_IDENT:
 191         unref(term->ident, string);
 192         break;
 193     case A_BRACKET:
 194         unref(term->brexp, term);
 195         break;
 196     case A_FUNC:
 197         unref(term->param, param);
 198         unref(term->body, term);
 199         break;
 200     case A_REP:
 201         unref(term->rexp, term);
 202         break;
 203     case A_TEST:
 204         unref(term->test, term);
 205         unref(term->result, term);
 206         break;
 207     default:
 208         assert(0);
 209         break;
 210     }
 211     unref(term->next, term);
 212     unref(term->info, info);
 213     unref(term->type, type);
 214     free(term);
 215 }
 216
 217 static void free_binding(struct binding *binding) {
 218     if (binding == NULL)
 219         return;
 220     assert(binding->ref == 0);
 221     unref(binding->next, binding);
 222     unref(binding->ident, string);
 223     unref(binding->type, type);
 224     unref(binding->value, value);
 225     free(binding);
 226 }
 227
 228 void free_module(struct module *module) {
 229     if (module == NULL)
 230         return;
 231     assert(module->ref == 0);
 232     free(module->name);
 233     unref(module->next, module);
 234     unref(module->bindings, binding);
 235     unref(module->autoload, transform);
 236     free(module);
 237 }
 238
 239 void free_type(struct type *type) {
 240     if (type == NULL)
 241         return;
 242     assert(type->ref == 0);
 243
 244     if (type->tag == T_ARROW) {
 245         unref(type->dom, type);
 246         unref(type->img, type);
 247     }
 248     free(type);
 249 }
 250
 251 static void free_exn(struct exn *exn) {
 252     if (exn == NULL)
 253         return;
 254
 255     unref(exn->info, info);
 256     free(exn->message);
 257     for (int i=0; i < exn->nlines; i++) {
 258         free(exn->lines[i]);
 259     }
 260     free(exn->lines);
 261     free(exn);
 262 }
 263
 264 void free_value(struct value *v) {
 265     if (v == NULL)
 266         return;
 267     assert(v->ref == 0);
 268
 269     switch(v->tag) {
 270     case V_STRING:
 271         unref(v->string, string);
 272         break;
 273     case V_REGEXP:
 274         unref(v->regexp, regexp);
 275         break;
 276     case V_LENS:
 277         unref(v->lens, lens);
 278         break;
 279     case V_TREE:
 280         free_tree(v->origin);
 281         break;
 282     case V_FILTER:
 283         unref(v->filter, filter);
 284         break;
 285     case V_TRANSFORM:
 286         unref(v->transform, transform);
 287         break;
 288     case V_NATIVE:
 289         if (v->native)
 290             unref(v->native->type, type);
 291         free(v->native);
 292         break;
 293     case V_CLOS:
 294         unref(v->func, term);
 295         unref(v->bindings, binding);
 296         break;
 297     case V_EXN:
 298         free_exn(v->exn);
 299         break;
 300     case V_UNIT:
 301         break;
 302     default:
 303         assert(0);
 304     }
 305     unref(v->info, info);
 306     free(v);
 307 }
 308
 309 /*
 310  * Creation of (some) terms. Others are in parser.y
 311  * Refernce counted arguments are now owned by the returned object, i.e.
 312  * the make_* functions do not increment the count.
 313  * Returned objects have a referece count of 1.
 314  */
 315 struct term *make_term(enum term_tag tag, struct info *info) {
 316   struct term *term;
 317   if (make_ref(term) < 0) {
 318       unref(info, info);
 319   } else {
 320       term->tag = tag;
 321       term->info = info;
 322   }
 323   return term;
 324 }
 325
 326 struct term *make_param(char *name, struct type *type, struct info *info) {
 327   struct term *term = make_term(A_FUNC, info);
 328   if (term == NULL)
 329       goto error;
 330   make_ref_err(term->param);
 331   term->param->info = ref(term->info);
 332   make_ref_err(term->param->name);
 333   term->param->name->str = name;
 334   term->param->type = type;
 335   return term;
 336  error:
 337   unref(term, term);
 338   return NULL;
 339 }
 340
 341 struct value *make_value(enum value_tag tag, struct info *info) {
 342     struct value *value = NULL;
 343     if (make_ref(value) < 0) {
 344         unref(info, info);
 345     } else {
 346         value->tag = tag;
 347         value->info = info;
 348     }
 349     return value;
 350 }
 351
 352 struct value *make_unit(struct info *info) {
 353     return make_value(V_UNIT, info);
 354 }
 355
 356 struct term *make_app_term(struct term *lambda, struct term *arg,
 357                            struct info *info) {
 358   struct term *app = make_term(A_APP, info);
 359   if (app == NULL) {
 360       unref(lambda, term);
 361       unref(arg, term);
 362   } else {
 363       app->left = lambda;
 364       app->right = arg;
 365   }
 366   return app;
 367 }
 368
 369 struct term *make_app_ident(char *id, struct term *arg, struct info *info) {
 370     struct term *ident = make_term(A_IDENT, ref(info));
 371     ident->ident = make_string(id);
 372     if (ident->ident == NULL) {
 373         unref(arg, term);
 374         unref(info, info);
 375         unref(ident, term);
 376         return NULL;
 377     }
 378     return make_app_term(ident, arg, info);
 379 }
 380
 381 struct term *build_func(struct term *params, struct term *exp) {
 382   assert(params->tag == A_FUNC);
 383   if (params->next != NULL)
 384     exp = build_func(params->next, exp);
 385
 386   params->body = exp;
 387   params->next = NULL;
 388   return params;
 389 }
 390
 391 /* Ownership is taken as needed */
 392 static struct value *make_closure(struct term *func, struct binding *bnds) {
 393     struct value *v = NULL;
 394     if (make_ref(v) == 0) {
 395         v->tag  = V_CLOS;
 396         v->info = ref(func->info);
 397         v->func = ref(func);
 398         v->bindings = ref(bnds);
 399     }
 400     return v;
 401 }
 402
 403 struct value *make_exn_value(struct info *info,
 404                              const char *format, ...) {
 405     va_list ap;
 406     int r;
 407     struct value *v;
 408     char *message;
 409
 410     va_start(ap, format);
 411     r = vasprintf(&message, format, ap);
 412     va_end(ap);
 413     if (r == -1)
 414         return NULL;
 415
 416     v = make_value(V_EXN, ref(info));
 417     CALLOC(v->exn, 1);
 418     v->exn->info = info;
 419     v->exn->message = message;
 420
 421     return v;
 422 }
 423
 424 void exn_add_lines(struct value *v, int nlines, ...) {
 425     assert(v->tag == V_EXN);
 426
 427     va_list ap;
 428     if (REALLOC_N(v->exn->lines, v->exn->nlines + nlines) == -1)
 429         return;
 430     va_start(ap, nlines);
 431     for (int i=0; i < nlines; i++) {
 432         char *line = va_arg(ap, char *);
 433         v->exn->lines[v->exn->nlines + i] = line;
 434     }
 435     va_end(ap);
 436     v->exn->nlines += nlines;
 437 }
 438
 439 void exn_printf_line(struct value *exn, const char *format, ...) {
 440     va_list ap;
 441     int r;
 442     char *line;
 443
 444     va_start(ap, format);
 445     r = vasprintf(&line, format, ap);
 446     va_end(ap);
 447     if (r >= 0)
 448         exn_add_lines(exn, 1, line);
 449 }
 450
 451 /*
 452  * Modules
 453  */
 454 static int load_module(struct augeas *aug, const char *name);
 455 static char *module_basename(const char *modname);
 456
 457 struct module *module_create(const char *name) {
 458     struct module *module;
 459     make_ref(module);
 460     module->name = strdup(name);
 461     return module;
 462 }
 463
 464 static struct module *module_find(struct module *module, const char *name) {
 465     list_for_each(e, module) {
 466         if (STRCASEEQ(e->name, name))
 467             return e;
 468     }
 469     return NULL;
 470 }
 471
 472 static struct binding *bnd_lookup(struct binding *bindings, const char *name) {
 473     list_for_each(b, bindings) {
 474         if (STREQ(b->ident->str, name))
 475             return b;
 476     }
 477     return NULL;
 478 }
 479
 480 static char *modname_of_qname(const char *qname) {
 481     char *dot = strchr(qname, '.');
 482     if (dot == NULL)
 483         return NULL;
 484
 485     return strndup(qname, dot - qname);
 486 }
 487
 488 static int lookup_internal(struct augeas *aug, const char *ctx_modname,
 489                            const char *name, struct binding **bnd) {
 490     char *modname = modname_of_qname(name);
 491
 492     *bnd = NULL;
 493
 494     if (modname == NULL) {
 495         struct module *builtin =
 496             module_find(aug->modules, builtin_module);
 497         assert(builtin != NULL);
 498         *bnd = bnd_lookup(builtin->bindings, name);
 499         return 0;
 500     }
 501
 502  qual_lookup:
 503     list_for_each(module, aug->modules) {
 504         if (STRCASEEQ(module->name, modname)) {
 505             *bnd = bnd_lookup(module->bindings, name + strlen(modname) + 1);
 506             free(modname);
 507             return 0;
 508         }
 509     }
 510     /* Try to load the module */
 511     if (streqv(modname, ctx_modname)) {
 512         free(modname);
 513         return 0;
 514     }
 515     int loaded = load_module(aug, modname) == 0;
 516     if (loaded)
 517         goto qual_lookup;
 518
 519     free(modname);
 520     return -1;
 521 }
 522
 523 struct lens *lens_lookup(struct augeas *aug, const char *qname) {
 524     struct binding *bnd = NULL;
 525
 526     if (lookup_internal(aug, NULL, qname, &bnd) < 0)
 527         return NULL;
 528     if (bnd == NULL || bnd->value->tag != V_LENS)
 529         return NULL;
 530     return bnd->value->lens;
 531 }
 532
 533 static struct binding *ctx_lookup_bnd(struct info *info,
 534                                       struct ctx *ctx, const char *name) {
 535     struct binding *b = NULL;
 536     int nlen = strlen(ctx->name);
 537
 538     if (STREQLEN(ctx->name, name, nlen) && name[nlen] == '.')
 539         name += nlen + 1;
 540
 541     b = bnd_lookup(ctx->local, name);
 542     if (b != NULL)
 543         return b;
 544
 545     if (ctx->aug != NULL) {
 546         int r;
 547         r = lookup_internal(ctx->aug, ctx->name, name, &b);
 548         if (r == 0)
 549             return b;
 550         char *modname = modname_of_qname(name);
 551         syntax_error(info, "Could not load module %s for %s",
 552                      modname, name);
 553         free(modname);
 554         return NULL;
 555     }
 556     return NULL;
 557 }
 558
 559 static struct value *ctx_lookup(struct info *info,
 560                                 struct ctx *ctx, struct string *ident) {
 561     struct binding *b = ctx_lookup_bnd(info, ctx, ident->str);
 562     return b == NULL ? NULL : b->value;
 563 }
 564
 565 static struct type *ctx_lookup_type(struct info *info,
 566                                     struct ctx *ctx, struct string *ident) {
 567     struct binding *b = ctx_lookup_bnd(info, ctx, ident->str);
 568     return b == NULL ? NULL : b->type;
 569 }
 570
 571 /* Takes ownership as needed */
 572 static struct binding *bind_type(struct binding **bnds,
 573                                  const char *name, struct type *type) {
 574     struct binding *binding;
 575
 576     if (STREQ(name, anon_ident))
 577         return NULL;
 578     make_ref(binding);
 579     make_ref(binding->ident);
 580     binding->ident->str = strdup(name);
 581     binding->type = ref(type);
 582     list_cons(*bnds, binding);
 583
 584     return binding;
 585 }
 586
 587 /* Takes ownership as needed */
 588 static void bind_param(struct binding **bnds, struct param *param,
 589                        struct value *v) {
 590     struct binding *b;
 591     make_ref(b);
 592     b->ident = ref(param->name);
 593     b->type  = ref(param->type);
 594     b->value = ref(v);
 595     ref(*bnds);
 596     list_cons(*bnds, b);
 597 }
 598
 599 static void unbind_param(struct binding **bnds, ATTRIBUTE_UNUSED struct param *param) {
 600     struct binding *b = *bnds;
 601     assert(b->ident == param->name);
 602     assert(b->next != *bnds);
 603     *bnds = b->next;
 604     unref(b, binding);
 605 }
 606
 607 /* Takes ownership of VALUE */
 608 static void bind(struct binding **bnds,
 609                  const char *name, struct type *type, struct value *value) {
 610     struct binding *b = NULL;
 611
 612     if (STRNEQ(name, anon_ident)) {
 613         b = bind_type(bnds, name, type);
 614         b->value = ref(value);
 615     }
 616 }
 617
 618 /*
 619  * Some debug printing
 620  */
 621
 622 static char *type_string(struct type *t);
 623
 624 static void dump_bindings(struct binding *bnds) {
 625     list_for_each(b, bnds) {
 626         char *st = type_string(b->type);
 627         fprintf(stderr, "    %s: %s", b->ident->str, st);
 628         fprintf(stderr, " = ");
 629         print_value(stderr, b->value);
 630         fputc('\n', stderr);
 631         free(st);
 632     }
 633 }
 634
 635 static void dump_module(struct module *module) {
 636     if (module == NULL)
 637         return;
 638     fprintf(stderr, "Module %s\n:", module->name);
 639     dump_bindings(module->bindings);
 640     dump_module(module->next);
 641 }
 642
 643 ATTRIBUTE_UNUSED
 644 static void dump_ctx(struct ctx *ctx) {
 645     fprintf(stderr, "Context: %s\n", ctx->name);
 646     dump_bindings(ctx->local);
 647     if (ctx->aug != NULL) {
 648         list_for_each(m, ctx->aug->modules)
 649             dump_module(m);
 650     }
 651 }
 652
 653 /*
 654  * Values
 655  */
 656 void print_tree_braces(FILE *out, int indent, struct tree *tree) {
 657     if (tree == NULL) {
 658         fprintf(out, "(null tree)\n");
 659         return;
 660     }
 661     list_for_each(t, tree) {
 662         for (int i=0; i < indent; i++) fputc(' ', out);
 663         fprintf(out, "{ ");
 664         if (t->label != NULL)
 665             fprintf(out, "\"%s\"", t->label);
 666         if (t->value != NULL)
 667             fprintf(out, " = \"%s\"", t->value);
 668         if (t->children != NULL) {
 669             fputc('\n', out);
 670             print_tree_braces(out, indent + 2, t->children);
 671             for (int i=0; i < indent; i++) fputc(' ', out);
 672         } else {
 673             fputc(' ', out);
 674         }
 675         fprintf(out, "}\n");
 676     }
 677 }
 678
 679 static void print_value(FILE *out, struct value *v) {
 680     if (v == NULL) {
 681         fprintf(out, "<null>");
 682         return;
 683     }
 684
 685     switch(v->tag) {
 686     case V_STRING:
 687         fprintf(out, "\"%s\"", v->string->str);
 688         break;
 689     case V_REGEXP:
 690         fprintf(out, "/%s/", v->regexp->pattern->str);
 691         break;
 692     case V_LENS:
 693         fprintf(out, "<lens:");
 694         print_info(out, v->lens->info);
 695         fprintf(out, ">");
 696         break;
 697     case V_TREE:
 698         print_tree_braces(out, 0, v->origin);
 699         break;
 700     case V_FILTER:
 701         fprintf(out, "<filter:");
 702         list_for_each(f, v->filter) {
 703             fprintf(out, "%c%s%c", f->include ? '+' : '-', f->glob->str,
 704                    (f->next != NULL) ? ':' : '>');
 705         }
 706         break;
 707     case V_TRANSFORM:
 708         fprintf(out, "<transform:");
 709         print_info(out, v->transform->lens->info);
 710         fprintf(out, ">");
 711         break;
 712     case V_NATIVE:
 713         fprintf(out, "<native:");
 714         print_info(out, v->info);
 715         fprintf(out, ">");
 716         break;
 717     case V_CLOS:
 718         fprintf(out, "<closure:");
 719         print_info(out, v->func->info);
 720         fprintf(out, ">");
 721         break;
 722     case V_EXN:
 723         if (! v->exn->seen) {
 724             print_info(out, v->exn->info);
 725             fprintf(out, "exception: %s\n", v->exn->message);
 726             for (int i=0; i < v->exn->nlines; i++) {
 727                 fprintf(out, "    %s\n", v->exn->lines[i]);
 728             }
 729             v->exn->seen = 1;
 730         }
 731         break;
 732     case V_UNIT:
 733         fprintf(out, "()");
 734         break;
 735     default:
 736         assert(0);
 737         break;
 738     }
 739 }
 740
 741 static int value_equal(struct value *v1, struct value *v2) {
 742     if (v1 == NULL && v2 == NULL)
 743         return 1;
 744     if (v1 == NULL || v2 == NULL)
 745         return 0;
 746     if (v1->tag != v2->tag)
 747         return 0;
 748     switch (v1->tag) {
 749     case V_STRING:
 750         return STREQ(v1->string->str, v2->string->str);
 751         break;
 752     case V_REGEXP:
 753         // FIXME: Should probably build FA's and compare them
 754         return STREQ(v1->regexp->pattern->str, v2->regexp->pattern->str);
 755         break;
 756     case V_LENS:
 757         return v1->lens == v2->lens;
 758         break;
 759     case V_TREE:
 760         return tree_equal(v1->origin->children, v2->origin->children);
 761         break;
 762     case V_FILTER:
 763         return v1->filter == v2->filter;
 764         break;
 765     case V_TRANSFORM:
 766         return v1->transform == v2->transform;
 767         break;
 768     case V_NATIVE:
 769         return v1->native == v2->native;
 770         break;
 771     case V_CLOS:
 772         return v1->func == v2->func && v1->bindings == v2->bindings;
 773         break;
 774     default:
 775         assert(0);
 776         abort();
 777         break;
 778     }
 779 }
 780
 781 /*
 782  * Types
 783  */
 784 struct type *make_arrow_type(struct type *dom, struct type *img) {
 785   struct type *type;
 786   make_ref(type);
 787   type->tag = T_ARROW;
 788   type->dom = ref(dom);
 789   type->img = ref(img);
 790   return type;
 791 }
 792
 793 struct type *make_base_type(enum type_tag tag) {
 794     if (tag == T_STRING)
 795         return (struct type *) t_string;
 796     else if (tag == T_REGEXP)
 797         return (struct type *) t_regexp;
 798     else if (tag == T_LENS)
 799         return (struct type *) t_lens;
 800     else if (tag == T_TREE)
 801         return (struct type *) t_tree;
 802     else if (tag == T_FILTER)
 803         return (struct type *) t_filter;
 804     else if (tag == T_TRANSFORM)
 805         return (struct type *) t_transform;
 806     else if (tag == T_UNIT)
 807         return (struct type *) t_unit;
 808     assert(0);
 809     abort();
 810 }
 811
 812 static const char *type_name(struct type *t) {
 813     for (int i = 0; type_names[i] != NULL; i++)
 814         if (i == t->tag)
 815             return type_names[i];
 816     assert(0);
 817     abort();
 818 }
 819
 820 static char *type_string(struct type *t) {
 821     if (t->tag == T_ARROW) {
 822         char *s = NULL;
 823         int r;
 824         char *sd = type_string(t->dom);
 825         char *si = type_string(t->img);
 826         if (t->dom->tag == T_ARROW)
 827             r = asprintf(&s, "(%s) -> %s", sd, si);
 828         else
 829             r = asprintf(&s, "%s -> %s", sd, si);
 830         free(sd);
 831         free(si);
 832         return (r == -1) ? NULL : s;
 833     } else {
 834         return strdup(type_name(t));
 835     }
 836 }
 837
 838 /* Decide whether T1 is a subtype of T2. The only subtype relations are
 839  * T_STRING <: T_REGEXP and the usual subtyping of functions based on
 840  * comparing domains/images
 841  *
 842  * Return 1 if T1 is a subtype of T2, 0 otherwise
 843  */
 844 static int subtype(struct type *t1, struct type *t2) {
 845     if (t1 == t2)
 846         return 1;
 847     /* We only promote T_STRING => T_REGEXP, no automatic conversion
 848        of strings/regexps to lenses (yet) */
 849     if (t1->tag == T_STRING)
 850         return (t2->tag == T_STRING || t2->tag == T_REGEXP);
 851     if (t1->tag == T_ARROW && t2->tag == T_ARROW) {
 852         return subtype(t2->dom, t1->dom)
 853             && subtype(t1->img, t2->img);
 854     }
 855     return t1->tag == t2->tag;
 856 }
 857
 858 static int type_equal(struct type *t1, struct type *t2) {
 859     return (t1 == t2) || (subtype(t1, t2) && subtype(t2, t1));
 860 }
 861
 862 /* Return a type T with subtype(T, T1) && subtype(T, T2) */
 863 static struct type *type_meet(struct type *t1, struct type *t2);
 864
 865 /* Return a type T with subtype(T1, T) && subtype(T2, T) */
 866 static struct type *type_join(struct type *t1, struct type *t2) {
 867     if (t1->tag == T_STRING) {
 868         if (t2->tag == T_STRING)
 869             return ref(t1);
 870         else if (t2->tag == T_REGEXP)
 871             return ref(t2);
 872     } else if (t1->tag == T_REGEXP) {
 873         if (t2->tag == T_STRING || t2->tag == T_REGEXP)
 874             return ref(t1);
 875     } else if (t1->tag == T_ARROW) {
 876         if (t2->tag != T_ARROW)
 877             return NULL;
 878         struct type *dom = type_meet(t1->dom, t2->dom);
 879         struct type *img = type_join(t1->img, t2->img);
 880         if (dom == NULL || img == NULL) {
 881             unref(dom, type);
 882             unref(img, type);
 883             return NULL;
 884         }
 885         return make_arrow_type(dom, img);
 886     } else if (type_equal(t1, t2)) {
 887         return ref(t1);
 888     }
 889     return NULL;
 890 }
 891
 892 /* Return a type T with subtype(T, T1) && subtype(T, T2) */
 893 static struct type *type_meet(struct type *t1, struct type *t2) {
 894     if (t1->tag == T_STRING) {
 895         if (t2->tag == T_STRING || t2->tag == T_REGEXP)
 896             return ref(t1);
 897     } else if (t1->tag == T_REGEXP) {
 898         if (t2->tag == T_STRING || t2->tag == T_REGEXP)
 899             return ref(t2);
 900     } else if (t1->tag == T_ARROW) {
 901         if (t2->tag != T_ARROW)
 902             return NULL;
 903         struct type *dom = type_join(t1->dom, t2->dom);
 904         struct type *img = type_meet(t1->img, t2->img);
 905         if (dom == NULL || img == NULL) {
 906             unref(dom, type);
 907             unref(img, type);
 908             return NULL;
 909         }
 910         return make_arrow_type(dom, img);
 911     } else if (type_equal(t1, t2)) {
 912         return ref(t1);
 913     }
 914     return NULL;
 915 }
 916
 917 static struct type *value_type(struct value *v) {
 918     switch(v->tag) {
 919     case V_STRING:
 920         return make_base_type(T_STRING);
 921     case V_REGEXP:
 922         return make_base_type(T_REGEXP);
 923     case V_LENS:
 924         return make_base_type(T_LENS);
 925     case V_TREE:
 926         return make_base_type(T_TREE);
 927     case V_FILTER:
 928         return make_base_type(T_FILTER);
 929     case V_TRANSFORM:
 930         return make_base_type(T_TRANSFORM);
 931     case V_UNIT:
 932         return make_base_type(T_UNIT);
 933     case V_NATIVE:
 934         return ref(v->native->type);
 935     case V_CLOS:
 936         return ref(v->func->type);
 937     case V_EXN:   /* Fail on exceptions */
 938     default:
 939         assert(0);
 940         abort();
 941     }
 942 }
 943
 944 /* Coerce V to the type T. Currently, only T_STRING can be coerced to
 945  * T_REGEXP. Returns a value that is owned by the caller. Trying to perform
 946  * an impossible coercion is a fatal error. Receives ownership of V.
 947  */
 948 static struct value *coerce(struct value *v, struct type *t) {
 949     struct type *vt = value_type(v);
 950     if (type_equal(vt, t)) {
 951         unref(vt, type);
 952         return v;
 953     }
 954     if (vt->tag == T_STRING && t->tag == T_REGEXP) {
 955         struct value *rxp = make_value(V_REGEXP, ref(v->info));
 956         rxp->regexp = make_regexp_literal(v->info, v->string->str);
 957         unref(v, value);
 958         unref(vt, type);
 959         return rxp;
 960     }
 961     return make_exn_value(v->info, "Type %s can not be coerced to %s",
 962                           type_name(vt), type_name(t));
 963 }
 964
 965 /* Return one of the expected types (passed as ...).
 966    Does not give ownership of the returned type */
 967 static struct type *expect_types_arr(struct info *info,
 968                                      struct type *act,
 969                                      int ntypes, struct type *allowed[]) {
 970     struct type *result = NULL;
 971
 972     for (int i=0; i < ntypes; i++) {
 973         if (subtype(act, allowed[i])) {
 974             result = allowed[i];
 975             break;
 976         }
 977     }
 978     if (result == NULL) {
 979         int len = 0;
 980         for (int i=0; i < ntypes; i++) {
 981             len += strlen(type_name(allowed[i]));
 982         }
 983         len += (ntypes - 1) * 4 + 1;
 984         char *allowed_names;
 985         CALLOC(allowed_names, len);
 986         for (int i=0; i < ntypes; i++) {
 987             if (i > 0)
 988                 strcat(allowed_names, (i == ntypes - 1) ? ", or " : ", ");
 989             strcat(allowed_names, type_name(allowed[i]));
 990         }
 991         char *act_str = type_string(act);
 992         syntax_error(info, "type error: expected %s but found %s",
 993                      allowed_names, act_str);
 994         free(act_str);
 995         free(allowed_names);
 996     }
 997     return result;
 998 }
 999
1000 static struct type *expect_types(struct info *info,
1001                                  struct type *act, int ntypes, ...) {
1002     va_list ap;
1003     struct type *allowed[ntypes];
1004
1005     va_start(ap, ntypes);
1006     for (int i=0; i < ntypes; i++)
1007         allowed[i] = va_arg(ap, struct type *);
1008     va_end(ap);
1009     return expect_types_arr(info, act, ntypes, allowed);
1010 }
1011
1012 static struct value *apply(struct term *app, struct ctx *ctx);
1013
1014 typedef struct value *(*impl0)(struct info *);
1015 typedef struct value *(*impl1)(struct info *, struct value *);
1016 typedef struct value *(*impl2)(struct info *, struct value *, struct value *);
1017 typedef struct value *(*impl3)(struct info *, struct value *, struct value *,
1018                                struct value *);
1019 typedef struct value *(*impl4)(struct info *, struct value *, struct value *,
1020                                struct value *, struct value *);
1021 typedef struct value *(*impl5)(struct info *, struct value *, struct value *,
1022                                struct value *, struct value *, struct value *);
1023
1024 static struct value *native_call(struct info *info,
1025                                  struct native *func, struct ctx *ctx) {
1026     struct value *argv[func->argc];
1027     struct binding *b = ctx->local;
1028     struct value *result;
1029
1030     for (int i = func->argc - 1; i >= 0; i--) {
1031         argv[i] = b->value;
1032         b = b->next;
1033     }
1034
1035     switch(func->argc) {
1036     case 0:
1037         result = ((impl0) *func->impl)(info);
1038         break;
1039     case 1:
1040         result = ((impl1) *func->impl)(info, argv[0]);
1041         break;
1042     case 2:
1043         result = ((impl2) *func->impl)(info, argv[0], argv[1]);
1044         break;
1045     case 3:
1046         result = ((impl3) *func->impl)(info, argv[0], argv[1], argv[2]);
1047         break;
1048     case 4:
1049         result = ((impl4) *func->impl)(info, argv[0], argv[1], argv[2], argv[3]);
1050         break;
1051     case 5:
1052         result = ((impl5) *func->impl)(info, argv[0], argv[1], argv[2], argv[3],
1053                                        argv[4]);
1054         break;
1055     default:
1056         assert(0);
1057         abort();
1058         break;
1059     }
1060
1061     return result;
1062 }
1063
1064 static void type_error1(struct info *info, const char *msg, struct type *type) {
1065     char *s = type_string(type);
1066     syntax_error(info, "Type error: ");
1067     syntax_error(info, msg, s);
1068     free(s);
1069 }
1070
1071 static void type_error2(struct info *info, const char *msg,
1072                         struct type *type1, struct type *type2) {
1073     char *s1 = type_string(type1);
1074     char *s2 = type_string(type2);
1075     syntax_error(info, "Type error: ");
1076     syntax_error(info, msg, s1, s2);
1077     free(s1);
1078     free(s2);
1079 }
1080
1081 static void type_error_binop(struct info *info, const char *opname,
1082                              struct type *type1, struct type *type2) {
1083     char *s1 = type_string(type1);
1084     char *s2 = type_string(type2);
1085     syntax_error(info, "Type error: ");
1086     syntax_error(info, "%s of %s and %s is not possible", opname, s1, s2);
1087     free(s1);
1088     free(s2);
1089 }
1090
1091 static int check_exp(struct term *term, struct ctx *ctx);
1092
1093 static struct type *require_exp_type(struct term *term, struct ctx *ctx,
1094                                      int ntypes, struct type *allowed[]) {
1095     int r = 1;
1096
1097     if (term->type == NULL) {
1098         r = check_exp(term, ctx);
1099         if (! r)
1100             return NULL;
1101     }
1102
1103     return expect_types_arr(term->info, term->type, ntypes, allowed);
1104 }
1105
1106 static int check_compose(struct term *term, struct ctx *ctx) {
1107     struct type *tl = NULL, *tr = NULL;
1108
1109     if (! check_exp(term->left, ctx))
1110         return 0;
1111     tl = term->left->type;
1112
1113     if (tl->tag == T_ARROW) {
1114         /* Composition of functions f: a -> b and g: c -> d is defined as
1115            (f . g) x = g (f x) and is type correct if b <: c yielding a
1116            function with type a -> d */
1117         if (! check_exp(term->right, ctx))
1118             return 0;
1119         tr = term->right->type;
1120         if (tr->tag != T_ARROW)
1121             goto print_error;
1122         if (! subtype(tl->img, tr->dom))
1123             goto print_error;
1124         term->type = make_arrow_type(tl->dom, tr->img);
1125     } else if (tl->tag == T_UNIT) {
1126         if (! check_exp(term->right, ctx))
1127             return 0;
1128         term->type = ref(term->right->type);
1129     } else {
1130         goto print_error;
1131     }
1132     return 1;
1133  print_error:
1134     type_error_binop(term->info,
1135                      "composition", term->left->type, term->right->type);
1136     return 0;
1137 }
1138
1139 static int check_binop(const char *opname, struct term *term,
1140                        struct ctx *ctx, int ntypes, ...) {
1141     va_list ap;
1142     struct type *allowed[ntypes];
1143     struct type *tl = NULL, *tr = NULL;
1144
1145     va_start(ap, ntypes);
1146     for (int i=0; i < ntypes; i++)
1147         allowed[i] = va_arg(ap, struct type *);
1148     va_end(ap);
1149
1150     tl = require_exp_type(term->left, ctx, ntypes, allowed);
1151     if (tl == NULL)
1152         return 0;
1153
1154     tr = require_exp_type(term->right, ctx, ntypes, allowed);
1155     if (tr == NULL)
1156         return 0;
1157
1158     term->type = type_join(tl, tr);
1159     if (term->type == NULL)
1160         goto print_error;
1161     return 1;
1162  print_error:
1163     type_error_binop(term->info, opname, term->left->type, term->right->type);
1164     return 0;
1165 }
1166
1167 static int check_value(struct value *v) {
1168     const char *msg;
1169
1170     if (v->tag == V_REGEXP) {
1171         if (regexp_check(v->regexp, &msg) == -1) {
1172             syntax_error(v->info, "Invalid regular expression: %s", msg);
1173             return 0;
1174         }
1175     }
1176     return 1;
1177 }
1178
1179 /* Return 1 if TERM passes, 0 otherwise */
1180 static int check_exp(struct term *term, struct ctx *ctx) {
1181     int result = 1;
1182     assert(term->type == NULL || term->tag == A_VALUE || term->ref > 1);
1183     if (term->type != NULL && term->tag != A_VALUE)
1184         return 1;
1185
1186     switch (term->tag) {
1187     case A_UNION:
1188         result = check_binop("union", term, ctx, 2, t_regexp, t_lens);
1189         break;
1190     case A_MINUS:
1191         result = check_binop("minus", term, ctx, 1, t_regexp);
1192         break;
1193     case A_COMPOSE:
1194         result = check_compose(term, ctx);
1195         break;
1196     case A_CONCAT:
1197         result = check_binop("concatenation", term, ctx,
1198                              4, t_string, t_regexp, t_lens, t_filter);
1199         break;
1200     case A_LET:
1201         {
1202             result = check_exp(term->right, ctx);
1203             if (result) {
1204                 struct term *func = term->left;
1205                 assert(func->tag == A_FUNC);
1206                 assert(func->param->type == NULL);
1207                 func->param->type = ref(term->right->type);
1208
1209                 result = check_exp(func, ctx);
1210                 if (result) {
1211                     term->tag = A_APP;
1212                     term->type = ref(func->type->img);
1213                 }
1214             }
1215         }
1216         break;
1217     case A_APP:
1218         result = check_exp(term->left, ctx) & check_exp(term->right, ctx);
1219         if (result) {
1220             if (term->left->type->tag != T_ARROW) {
1221                 type_error1(term->info,
1222                             "expected function in application but found %s",
1223                             term->left->type);
1224                 result = 0;
1225             };
1226         }
1227         if (result) {
1228             result = expect_types(term->info,
1229                                   term->right->type,
1230                                   1, term->left->type->dom) != NULL;
1231             if (! result) {
1232                 type_error_binop(term->info, "application",
1233                                  term->left->type, term->right->type);
1234                 result = 0;
1235             }
1236         }
1237         if (result)
1238             term->type = ref(term->left->type->img);
1239         break;
1240     case A_VALUE:
1241         result = check_value(term->value);
1242         break;
1243     case A_IDENT:
1244         {
1245             struct type *t = ctx_lookup_type(term->info, ctx, term->ident);
1246             if (t == NULL) {
1247                 syntax_error(term->info, "Undefined variable %s",
1248                              term->ident->str);
1249                 result = 0;
1250             } else {
1251                 term->type = ref(t);
1252             }
1253         }
1254         break;
1255     case A_BRACKET:
1256         result = check_exp(term->brexp, ctx);
1257         if (result) {
1258             term->type = ref(expect_types(term->info, term->brexp->type,
1259                                           1, t_lens));
1260             if (term->type == NULL) {
1261                 type_error1(term->info,
1262                              "[..] is only defined for lenses, not for %s",
1263                             term->brexp->type);
1264                 result = 0;
1265             }
1266         }
1267         break;
1268     case A_FUNC:
1269         {
1270             bind_param(&ctx->local, term->param, NULL);
1271             result = check_exp(term->body, ctx);
1272             if (result) {
1273                 term->type =
1274                     make_arrow_type(term->param->type, term->body->type);
1275             }
1276             unbind_param(&ctx->local, term->param);
1277         }
1278         break;
1279     case A_REP:
1280         result = check_exp(term->exp, ctx);
1281         if (result) {
1282             term->type = ref(expect_types(term->info, term->exp->type, 2,
1283                                           t_regexp, t_lens));
1284             if (term->type == NULL) {
1285                 type_error1(term->info,
1286                             "Incompatible types: repetition is only defined"
1287                             " for regexp and lens, not for %s",
1288                             term->exp->type);
1289                 result = 0;
1290             }
1291         }
1292         break;
1293     default:
1294         assert(0);
1295         break;
1296     }
1297     assert(!result || term->type != NULL);
1298     return result;
1299 }
1300
1301 static int check_decl(struct term *term, struct ctx *ctx) {
1302     assert(term->tag == A_BIND || term->tag == A_TEST);
1303
1304     if (term->tag == A_BIND) {
1305         if (!check_exp(term->exp, ctx))
1306             return 0;
1307         term->type = ref(term->exp->type);
1308
1309         if (bnd_lookup(ctx->local, term->bname) != NULL) {
1310             syntax_error(term->info,
1311                          "the name %s is already defined", term->bname);
1312             return 0;
1313         }
1314         bind_type(&ctx->local, term->bname, term->type);
1315     } else if (term->tag == A_TEST) {
1316         if (!check_exp(term->test, ctx))
1317             return 0;
1318         if (term->result != NULL) {
1319             if (!check_exp(term->result, ctx))
1320                 return 0;
1321             if (! type_equal(term->test->type, term->result->type)) {
1322                 type_error2(term->info,
1323                             "expected test result of type %s but got %s",
1324                             term->result->type, term->test->type);
1325                 return 0;
1326             }
1327         } else {
1328             if (expect_types(term->info, term->test->type, 2,
1329                              t_string, t_tree) == NULL)
1330                 return 0;
1331         }
1332         term->type = ref(term->test->type);
1333     } else {
1334         assert(0);
1335     }
1336     return 1;
1337 }
1338
1339 static int typecheck(struct term *term, struct augeas *aug) {
1340     int ok = 1;
1341     struct ctx ctx;
1342     char *fname;
1343     const char *basenam;
1344
1345     assert(term->tag == A_MODULE);
1346
1347     /* Check that the module name is consistent with the filename */
1348     fname = module_basename(term->mname);
1349
1350     basenam = strrchr(term->info->filename->str, SEP);
1351     if (basenam == NULL)
1352         basenam = term->info->filename->str;
1353     else
1354         basenam += 1;
1355     if (STRNEQ(fname, basenam)) {
1356         syntax_error(term->info,
1357                      "The module %s must be in a file named %s",
1358                      term->mname, fname);
1359         free(fname);
1360         return 0;
1361     }
1362     free(fname);
1363
1364     ctx.aug = aug;
1365     ctx.local = NULL;
1366     ctx.name = term->mname;
1367     list_for_each(dcl, term->decls) {
1368         ok &= check_decl(dcl, &ctx);
1369     }
1370     unref(ctx.local, binding);
1371     return ok;
1372 }
1373
1374 static struct value *compile_exp(struct info *, struct term *, struct ctx *);
1375
1376 static struct value *compile_union(struct term *exp, struct ctx *ctx) {
1377     struct value *v1 = compile_exp(exp->info, exp->left, ctx);
1378     if (EXN(v1))
1379         return v1;
1380     struct value *v2 = compile_exp(exp->info, exp->right, ctx);
1381     if (EXN(v2)) {
1382         unref(v1, value);
1383         return v2;
1384     }
1385
1386     struct type *t = exp->type;
1387     struct info *info = exp->info;
1388     struct value *v = NULL;
1389
1390     v1 = coerce(v1, t);
1391     if (EXN(v1))
1392         return v1;
1393     v2 = coerce(v2, t);
1394     if (EXN(v2)) {
1395         unref(v1, value);
1396         return v2;
1397     }
1398
1399     if (t->tag == T_REGEXP) {
1400         v = make_value(V_REGEXP, ref(info));
1401         v->regexp = regexp_union(info, v1->regexp, v2->regexp);
1402     } else if (t->tag == T_LENS) {
1403         struct lens *l1 = v1->lens;
1404         struct lens *l2 = v2->lens;
1405         v = lns_make_union(ref(info), ref(l1), ref(l2), LNS_TYPE_CHECK(ctx));
1406     } else {
1407         fatal_error(info, "Tried to union a %s and a %s to yield a %s",
1408                     type_name(exp->left->type), type_name(exp->right->type),
1409                     type_name(t));
1410     }
1411     unref(v1, value);
1412     unref(v2, value);
1413     return v;
1414 }
1415
1416 static struct value *compile_minus(struct term *exp, struct ctx *ctx) {
1417     struct value *v1 = compile_exp(exp->info, exp->left, ctx);
1418     if (EXN(v1))
1419         return v1;
1420     struct value *v2 = compile_exp(exp->info, exp->right, ctx);
1421     if (EXN(v2)) {
1422         unref(v1, value);
1423         return v2;
1424     }
1425
1426     struct type *t = exp->type;
1427     struct info *info = exp->info;
1428     struct value *v;
1429
1430     v1 = coerce(v1, t);
1431     v2 = coerce(v2, t);
1432     if (t->tag == T_REGEXP) {
1433         struct regexp *re1 = v1->regexp;
1434         struct regexp *re2 = v2->regexp;
1435         struct regexp *re = regexp_minus(info, re1, re2);
1436         if (re == NULL) {
1437             v = make_exn_value(ref(info),
1438                    "Regular expression subtraction 'r1 - r2' failed");
1439             exn_printf_line(v, "r1: /%s/", re1->pattern->str);
1440             exn_printf_line(v, "r2: /%s/", re2->pattern->str);
1441         } else {
1442             v = make_value(V_REGEXP, ref(info));
1443             v->regexp = re;
1444         }
1445     } else {
1446         v = NULL;
1447         fatal_error(info, "Tried to subtract a %s and a %s to yield a %s",
1448                     type_name(exp->left->type), type_name(exp->right->type),
1449                     type_name(t));
1450     }
1451     unref(v1, value);
1452     unref(v2, value);
1453     return v;
1454 }
1455
1456 static struct value *compile_compose(struct term *exp, struct ctx *ctx) {
1457     struct info *info = exp->info;
1458     struct value *v;
1459
1460     if (exp->left->type->tag == T_ARROW) {
1461         // FIXME: This is really crufty, and should be desugared in the
1462         // parser so that we don't have to do all this manual type
1463         // computation. Should we write function compostion as
1464         // concatenation instead of using a separate syntax ?
1465
1466         /* Build lambda x: exp->right (exp->left x) as a closure */
1467         char *var = strdup("@0");
1468         struct term *func = make_param(var, ref(exp->left->type->dom),
1469                                        ref(info));
1470         func->type = make_arrow_type(exp->left->type->dom,
1471                                      exp->right->type->img);
1472         struct term *ident = make_term(A_IDENT, ref(info));
1473         ident->ident = ref(func->param->name);
1474         ident->type = ref(func->param->type);
1475         struct term *app = make_app_term(ref(exp->left), ident, ref(info));
1476         app->type = ref(app->left->type->img);
1477         app = make_app_term(ref(exp->right), app, ref(info));
1478         app->type = ref(app->right->type->img);
1479
1480         build_func(func, app);
1481
1482         if (!type_equal(func->type, exp->type)) {
1483             char *f = type_string(func->type);
1484             char *e = type_string(exp->type);
1485             fatal_error(info,
1486               "Composition has type %s but should have type %s", f, e);
1487             free(f);
1488             free(e);
1489             unref(func, term);
1490             return info->error->exn;
1491         }
1492         v = make_closure(func, ctx->local);
1493         unref(func, term);
1494     } else {
1495         v = compile_exp(exp->info, exp->left, ctx);
1496         unref(v, value);
1497         v = compile_exp(exp->info, exp->right, ctx);
1498     }
1499     return v;
1500 }
1501
1502 static struct value *compile_concat(struct term *exp, struct ctx *ctx) {
1503     struct value *v1 = compile_exp(exp->info, exp->left, ctx);
1504     if (EXN(v1))
1505         return v1;
1506     struct value *v2 = compile_exp(exp->info, exp->right, ctx);
1507     if (EXN(v2)) {
1508         unref(v1, value);
1509         return v2;
1510     }
1511
1512     struct type *t = exp->type;
1513     struct info *info = exp->info;
1514     struct value *v;
1515
1516     v1 = coerce(v1, t);
1517     v2 = coerce(v2, t);
1518     if (t->tag == T_STRING) {
1519         const char *s1 = v1->string->str;
1520         const char *s2 = v2->string->str;
1521         v = make_value(V_STRING, ref(info));
1522         make_ref(v->string);
1523         CALLOC(v->string->str, strlen(s1) + strlen(s2) + 1);
1524         char *s = v->string->str;
1525         strcpy(s, s1);
1526         strcat(s, s2);
1527     } else if (t->tag == T_REGEXP) {
1528         v = make_value(V_REGEXP, ref(info));
1529         v->regexp = regexp_concat(info, v1->regexp, v2->regexp);
1530     } else if (t->tag == T_FILTER) {
1531         struct filter *f1 = v1->filter;
1532         struct filter *f2 = v2->filter;
1533         v = make_value(V_FILTER, ref(info));
1534         if (v2->ref == 1 && f2->ref == 1) {
1535             list_append(f2, ref(f1));
1536             v->filter = ref(f2);
1537         } else if (v1->ref == 1 && f1->ref == 1) {
1538             list_append(f1, ref(f2));
1539             v->filter = ref(f1);
1540         } else {
1541             struct filter *cf1, *cf2;
1542             cf1 = make_filter(ref(f1->glob), f1->include);
1543             cf2 = make_filter(ref(f2->glob), f2->include);
1544             cf1->next = ref(f1->next);
1545             cf2->next = ref(f2->next);
1546             list_append(cf1, cf2);
1547             v->filter = cf1;
1548         }
1549     } else if (t->tag == T_LENS) {
1550         struct lens *l1 = v1->lens;
1551         struct lens *l2 = v2->lens;
1552         v = lns_make_concat(ref(info), ref(l1), ref(l2), LNS_TYPE_CHECK(ctx));
1553     } else {
1554         v = NULL;
1555         fatal_error(info, "Tried to concat a %s and a %s to yield a %s",
1556                     type_name(exp->left->type), type_name(exp->right->type),
1557                     type_name(t));
1558     }
1559     unref(v1, value);
1560     unref(v2, value);
1561     return v;
1562 }
1563
1564 static struct value *apply(struct term *app, struct ctx *ctx) {
1565     struct value *f = compile_exp(app->info, app->left, ctx);
1566     struct value *result = NULL;
1567     struct ctx lctx;
1568
1569     if (EXN(f))
1570         return f;
1571
1572     struct value *arg = compile_exp(app->info, app->right, ctx);
1573     if (EXN(arg)) {
1574         unref(f, value);
1575         return arg;
1576     }
1577
1578     assert(f->tag == V_CLOS);
1579
1580     lctx.aug = ctx->aug;
1581     lctx.local = ref(f->bindings);
1582     lctx.name = ctx->name;
1583
1584     arg = coerce(arg, f->func->param->type);
1585     if (arg == NULL)
1586         goto done;
1587
1588     bind_param(&lctx.local, f->func->param, arg);
1589     result = compile_exp(app->info, f->func->body, &lctx);
1590     unref(result->info, info);
1591     result->info = ref(app->info);
1592     unbind_param(&lctx.local, f->func->param);
1593
1594  done:
1595     unref(lctx.local, binding);
1596     unref(arg, value);
1597     unref(f, value);
1598     return result;
1599 }
1600
1601 static struct value *compile_bracket(struct term *exp, struct ctx *ctx) {
1602     struct value *arg = compile_exp(exp->info, exp->brexp, ctx);
1603     if (EXN(arg))
1604         return arg;
1605     assert(arg->tag == V_LENS);
1606
1607     struct value *v = lns_make_subtree(ref(exp->info), ref(arg->lens));
1608     unref(arg, value);
1609
1610     return v;
1611 }
1612
1613 static struct value *compile_rep(struct term *rep, struct ctx *ctx) {
1614     struct value *arg = compile_exp(rep->info, rep->rexp, ctx);
1615     struct value *v = NULL;
1616
1617     if (EXN(arg))
1618         return arg;
1619
1620     arg = coerce(arg, rep->type);
1621     if (rep->type->tag == T_REGEXP) {
1622         int min, max;
1623         if (rep->quant == Q_STAR) {
1624             min = 0; max = -1;
1625         } else if (rep->quant == Q_PLUS) {
1626             min = 1; max = -1;
1627         } else if (rep->quant == Q_MAYBE) {
1628             min = 0; max = 1;
1629         } else {
1630             assert(0);
1631             abort();
1632         }
1633         v = make_value(V_REGEXP, ref(rep->info));
1634         v->regexp = regexp_iter(rep->info, arg->regexp, min, max);
1635     } else if (rep->type->tag == T_LENS) {
1636         int c = LNS_TYPE_CHECK(ctx);
1637         if (rep->quant == Q_STAR) {
1638             v = lns_make_star(ref(rep->info), ref(arg->lens), c);
1639         } else if (rep->quant == Q_PLUS) {
1640             v = lns_make_plus(ref(rep->info), ref(arg->lens), c);
1641         } else if (rep->quant == Q_MAYBE) {
1642             v = lns_make_maybe(ref(rep->info), ref(arg->lens), c);
1643         } else {
1644             assert(0);
1645         }
1646     } else {
1647         fatal_error(rep->info, "Tried to repeat a %s to yield a %s",
1648                     type_name(rep->rexp->type), type_name(rep->type));
1649     }
1650     unref(arg, value);
1651     return v;
1652 }
1653
1654 static struct value *compile_exp(struct info *info,
1655                                  struct term *exp, struct ctx *ctx) {
1656     struct value *v = NULL;
1657
1658     switch (exp->tag) {
1659     case A_COMPOSE:
1660         v = compile_compose(exp, ctx);
1661         break;
1662     case A_UNION:
1663         v = compile_union(exp, ctx);
1664         break;
1665     case A_MINUS:
1666         v = compile_minus(exp, ctx);
1667         break;
1668     case A_CONCAT:
1669         v = compile_concat(exp, ctx);
1670         break;
1671     case A_APP:
1672         v = apply(exp, ctx);
1673         break;
1674     case A_VALUE:
1675         if (exp->value->tag == V_NATIVE) {
1676             v = native_call(info, exp->value->native, ctx);
1677         } else {
1678             v = ref(exp->value);
1679         }
1680         break;
1681     case A_IDENT:
1682         v = ref(ctx_lookup(exp->info, ctx, exp->ident));
1683         break;
1684     case A_BRACKET:
1685         v = compile_bracket(exp, ctx);
1686         break;
1687     case A_FUNC:
1688         v = make_closure(exp, ctx->local);
1689         break;
1690     case A_REP:
1691         v = compile_rep(exp, ctx);
1692         break;
1693     default:
1694         assert(0);
1695         break;
1696     }
1697
1698     return v;
1699 }
1700
1701 static int compile_test(struct term *term, struct ctx *ctx) {
1702     struct value *actual = compile_exp(term->info, term->test, ctx);
1703     struct value *expect = NULL;
1704     int ret = 1;
1705
1706     if (term->tr_tag == TR_EXN) {
1707         if (!EXN(actual)) {
1708             print_info(stdout, term->info);
1709             printf("Test run should have produced exception, but produced\n");
1710             print_value(stdout, actual);
1711             printf("\n");
1712             ret = 0;
1713         }
1714     } else {
1715         if (EXN(actual)) {
1716             print_info(stdout, term->info);
1717             printf("exception thrown in test\n");
1718             print_value(stdout, actual);
1719             printf("\n");
1720             ret = 0;
1721         } else if (term->tr_tag == TR_CHECK) {
1722             expect = compile_exp(term->info, term->result, ctx);
1723             if (EXN(expect))
1724                 goto done;
1725             if (! value_equal(actual, expect)) {
1726                 printf("Test failure:");
1727                 print_info(stdout, term->info);
1728                 printf("\n");
1729                 printf(" Expected:\n");
1730                 print_value(stdout, expect);
1731                 printf("\n");
1732                 printf(" Actual:\n");
1733                 print_value(stdout, actual);
1734                 printf("\n");
1735                 ret = 0;
1736             }
1737         } else {
1738             printf("Test result: ");
1739             print_info(stdout, term->info);
1740             printf("\n");
1741             if (actual->tag == V_TREE) {
1742                 print_tree_braces(stdout, 2, actual->origin->children);
1743             } else {
1744                 print_value(stdout, actual);
1745             }
1746             printf("\n");
1747         }
1748     }
1749  done:
1750     reset_error(term->info->error);
1751     unref(actual, value);
1752     unref(expect, value);
1753     return ret;
1754 }
1755
1756 static int compile_decl(struct term *term, struct ctx *ctx) {
1757     if (term->tag == A_BIND) {
1758         int result;
1759
1760         struct value *v = compile_exp(term->info, term->exp, ctx);
1761         bind(&ctx->local, term->bname, term->type, v);
1762
1763         if (EXN(v) && !v->exn->seen) {
1764             struct error *error = term->info->error;
1765             struct memstream ms;
1766
1767             init_memstream(&ms);
1768
1769             syntax_error(term->info, "Failed to compile %s",
1770                          term->bname);
1771             fprintf(ms.stream, "%s\n", error->details);
1772             print_value(ms.stream, v);
1773             close_memstream(&ms);
1774
1775             v->exn->seen = 1;
1776             free(error->details);
1777             error->details = ms.buf;
1778         }
1779         result = !(EXN(v) || HAS_ERR(ctx->aug));
1780         unref(v, value);
1781         return result;
1782     } else if (term->tag == A_TEST) {
1783         return compile_test(term, ctx);
1784     }
1785     assert(0);
1786     abort();
1787 }
1788
1789 static struct module *compile(struct term *term, struct augeas *aug) {
1790     struct ctx ctx;
1791     struct transform *autoload = NULL;
1792     assert(term->tag == A_MODULE);
1793
1794     ctx.aug = aug;
1795     ctx.local = NULL;
1796     ctx.name = term->mname;
1797     list_for_each(dcl, term->decls) {
1798         if (!compile_decl(dcl, &ctx))
1799             goto error;
1800     }
1801
1802     if (term->autoload != NULL) {
1803         struct binding *bnd = bnd_lookup(ctx.local, term->autoload);
1804         if (bnd == NULL) {
1805             syntax_error(term->info, "Undefined transform in autoload %s",
1806                          term->autoload);
1807             goto error;
1808         }
1809         if (expect_types(term->info, bnd->type, 1, t_transform) == NULL)
1810             goto error;
1811         autoload = bnd->value->transform;
1812     }
1813     struct module *module = module_create(term->mname);
1814     module->bindings = ctx.local;
1815     module->autoload = ref(autoload);
1816     return module;
1817  error:
1818     unref(ctx.local, binding);
1819     return NULL;
1820 }
1821
1822 /*
1823  * Defining native functions
1824  */
1825 static struct info *
1826 make_native_info(struct error *error, const char *fname, int line) {
1827     struct info *info;
1828     if (make_ref(info) < 0)
1829         goto error;
1830     info->first_line = info->last_line = line;
1831     info->first_column = info->last_column = 0;
1832     info->error = error;
1833     if (make_ref(info->filename) < 0)
1834         goto error;
1835     info->filename->str = strdup(fname);
1836     return info;
1837  error:
1838     unref(info, info);
1839     return NULL;
1840 }
1841
1842 int define_native_intl(const char *file, int line,
1843                        struct error *error,
1844                        struct module *module, const char *name,
1845                        int argc, void *impl, ...) {
1846     assert(argc > 0);  /* We have no unit type */
1847     assert(argc <= 5);
1848     va_list ap;
1849     enum type_tag tag;
1850     struct term *params = NULL, *body = NULL, *func = NULL;
1851     struct type *type;
1852     struct value *v = NULL;
1853     struct info *info = NULL;
1854     struct ctx ctx;
1855
1856     info = make_native_info(error, file, line);
1857     if (info == NULL)
1858         goto error;
1859
1860     va_start(ap, impl);
1861     for (int i=0; i < argc; i++) {
1862         struct term *pterm;
1863         char ident[10];
1864         tag = va_arg(ap, enum type_tag);
1865         type = make_base_type(tag);
1866         snprintf(ident, 10, "@%d", i);
1867         pterm = make_param(strdup(ident), type, ref(info));
1868         list_append(params, pterm);
1869     }
1870     tag = va_arg(ap, enum type_tag);
1871     va_end(ap);
1872
1873     type = make_base_type(tag);
1874
1875     make_ref(v);
1876     if (v == NULL)
1877         goto error;
1878     v->tag = V_NATIVE;
1879     v->info = info;
1880     info = NULL;
1881
1882     if (ALLOC(v->native) < 0)
1883         goto error;
1884     v->native->argc = argc;
1885     v->native->type = type;
1886     v->native->impl = impl;
1887
1888     make_ref(body);
1889     if (body == NULL)
1890         goto error;
1891     body->info = ref(info);
1892     body->type = ref(type);
1893     body->tag = A_VALUE;
1894     body->value = v;
1895     v = NULL;
1896
1897     func = build_func(params, body);
1898     if (func == NULL)
1899         goto error;
1900     body = NULL;
1901
1902     ctx.aug = NULL;
1903     ctx.local = ref(module->bindings);
1904     ctx.name = module->name;
1905     if (! check_exp(func, &ctx)) {
1906         fatal_error(info, "Typechecking native %s failed",
1907                     name);
1908         abort();
1909     }
1910     v = make_closure(func, ctx.local);
1911     if (v == NULL) {
1912         unref(module->bindings, binding);
1913         goto error;
1914     }
1915     bind(&ctx.local, name, func->type, v);
1916     unref(v, value);
1917     unref(func, term);
1918     unref(module->bindings, binding);
1919
1920     module->bindings = ctx.local;
1921     return 0;
1922  error:
1923     unref(v, value);
1924     unref(body, term);
1925     unref(func, term);
1926     return -1;
1927 }
1928
1929
1930 /* Defined in parser.y */
1931 int augl_parse_file(struct augeas *aug, const char *name, struct term **term);
1932
1933 static char *module_basename(const char *modname) {
1934     char *fname;
1935
1936     if (asprintf(&fname, "%s" AUG_EXT, modname) == -1)
1937         return NULL;
1938     for (int i=0; i < strlen(modname); i++)
1939         fname[i] = tolower(fname[i]);
1940     return fname;
1941 }
1942
1943 static char *module_filename(struct augeas *aug, const char *modname) {
1944     char *dir = NULL;
1945     char *filename = NULL;
1946     char *name = module_basename(modname);
1947
1948     while ((dir = argz_next(aug->modpathz, aug->nmodpath, dir)) != NULL) {
1949         int len = strlen(name) + strlen(dir) + 2;
1950         struct stat st;
1951
1952         if (REALLOC_N(filename, len) == -1)
1953             goto error;
1954         sprintf(filename, "%s/%s", dir, name);
1955         if (stat(filename, &st) == 0)
1956             goto done;
1957     }
1958  error:
1959     FREE(filename);
1960  done:
1961     free(name);
1962     return filename;
1963 }
1964
1965 int load_module_file(struct augeas *aug, const char *filename) {
1966     struct term *term = NULL;
1967     int result = -1;
1968
1969     if (aug->flags & AUG_TRACE_MODULE_LOADING)
1970         printf("Module %s", filename);
1971     augl_parse_file(aug, filename, &term);
1972     if (aug->flags & AUG_TRACE_MODULE_LOADING)
1973         printf(HAS_ERR(aug) ? " failed\n" : " loaded\n");
1974     ERR_BAIL(aug);
1975
1976     if (! typecheck(term, aug))
1977         goto error;
1978
1979     struct module *module = compile(term, aug);
1980     ERR_THROW(module == NULL, aug, AUG_ESYNTAX,
1981               "Failed to load %s", filename);
1982
1983     list_append(aug->modules, module);
1984     result = 0;
1985  error:
1986     // FIXME: This leads to a bad free of a string used in a del lens
1987     // To reproduce run lenses/tests/test_yum.aug
1988     unref(term, term);
1989     return result;
1990 }
1991
1992 static int load_module(struct augeas *aug, const char *name) {
1993     char *filename = NULL;
1994
1995     if (module_find(aug->modules, name) != NULL)
1996         return 0;
1997
1998     if ((filename = module_filename(aug, name)) == NULL)
1999         return -1;
2000
2001     if (load_module_file(aug, filename) == -1)
2002         goto error;
2003
2004     free(filename);
2005     return 0;
2006
2007  error:
2008     free(filename);
2009     return -1;
2010 }
2011
2012 int interpreter_init(struct augeas *aug) {
2013     int r;
2014
2015     r = init_fatal_exn(aug->error);
2016     if (r < 0)
2017         return -1;
2018
2019     aug->modules = builtin_init(aug->error);
2020     if (aug->flags & AUG_NO_MODL_AUTOLOAD)
2021         return 0;
2022
2023     // For now, we just load every file on the search path
2024     const char *dir = NULL;
2025     glob_t globbuf;
2026     int gl_flags = GLOB_NOSORT;
2027
2028     MEMZERO(&globbuf, 1);
2029
2030     while ((dir = argz_next(aug->modpathz, aug->nmodpath, dir)) != NULL) {
2031         char *globpat;
2032         r = asprintf(&globpat, "%s/*.aug", dir);
2033         ERR_NOMEM(r < 0, aug);
2034
2035         r = glob(globpat, gl_flags, NULL, &globbuf);
2036         if (r != 0 && r != GLOB_NOMATCH) {
2037             /* This really has to be an allocation failure; glob is not
2038              * supposed to return GLOB_ABORTED here */
2039             aug_errcode_t code =
2040                 r == GLOB_NOSPACE ? AUG_ENOMEM : AUG_EINTERNAL;
2041             ERR_REPORT(aug, code, "glob failure for %s", globpat);
2042             free(globpat);
2043             goto error;
2044         }
2045         gl_flags |= GLOB_APPEND;
2046         free(globpat);
2047     }
2048
2049     for (int i=0; i < globbuf.gl_pathc; i++) {
2050         char *name, *p, *q;
2051         p = strrchr(globbuf.gl_pathv[i], SEP);
2052         if (p == NULL)
2053             p = globbuf.gl_pathv[i];
2054         else
2055             p += 1;
2056         q = strchr(p, '.');
2057         name = strndup(p, q - p);
2058         name[0] = toupper(name[0]);
2059         if (load_module(aug, name) == -1)
2060             goto error;
2061         free(name);
2062     }
2063     globfree(&globbuf);
2064     return 0;
2065  error:
2066     globfree(&globbuf);
2067     return -1;
2068 }
2069
2070 /*
2071  * Local variables:
2072  *  indent-tabs-mode: nil
2073  *  c-indent-level: 4
2074  *  c-basic-offset: 4
2075  *  tab-width: 4
2076  * End:
2077  */