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